11 import qualified Codec.Binary.UTF8.String as UTF8
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.Arrow.XmlIOStateArrow
27 import Text.XML.HXT.DOM.TypeDefs
28 import Text.XML.HXT.DOM.XmlKeywords
32 logger = "Rakka.Resource"
36 -- "/foo" ==> "/foo.html"
37 -- "/foo/" ==> "/foo.html"
38 -- "/foo.bar/" ==> "/foo.bar"
39 -- "/foo.bar" ==> "/foo.bar"
40 canonicalizeURI :: URI -> Resource ()
41 canonicalizeURI baseURI
42 = do rPath <- return . uriPath =<< getRequestURI
43 let newURI = baseURI { uriPath = uriPath baseURI </> newPath }
44 newPath = foldl (</>) "/" newPath'
45 newPath' = case [x | x <- splitBy (== '/') rPath, x /= ""] of
47 path -> case break (== '.') $ last path of
48 (_, "") -> let basePieces = reverse $ tail $ reverse path
51 basePieces ++ [lastPiece ++ ".html"]
53 when (rPath /= newPath)
54 $ abort MovedPermanently
55 [("Location", uriToString id newURI $ "")]
59 runIdempotentA :: URI -> IOSArrow () (Resource c) -> Resource c
60 runIdempotentA baseURI a
61 = do canonicalizeURI baseURI
62 [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
71 runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
72 runXmlA env schemaPath a
73 = do inputA <- getInputXmlA env schemaPath
74 [rsrc] <- liftIO $ runX ( inputA
76 setErrorMsgHandler False fail
83 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
84 -- Unprocessable Entity になる。入力の型が XML でない時は 415
85 -- Unsupported Media Type を返す。
86 getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
87 getInputXmlA env schemaPath
88 = do reader <- getInputReader
89 validator <- getValidator env schemaPath
90 return ( setErrorMsgHandler False (abort BadRequest [] . Just)
94 setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
100 getInputReader :: Resource (IOSArrow b XmlTree)
102 = do mimeType <- getContentType
105 -> getFailingReader BadRequest [] (Just "Missing Content-Type")
106 Just (MIMEType "text" "xml" _)
108 Just (MIMEType "application" "xml" _)
111 -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
114 = do req <- input defaultLimit
115 liftIO $ debugM logger req
116 return $ readString [ (a_validate , v_0)
117 , (a_check_namespaces , v_1)
118 , (a_remove_whitespace, v_0)
119 ] (UTF8.decodeString req)
120 getFailingReader code headers msg
121 = return $ proc _ -> abortA -< (code, (headers, msg))
124 getEntityType :: Resource MIMEType
126 = do uri <- getRequestURI
127 let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
128 case lookup ext extMap of
129 Just mType -> return mType
130 Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
132 extMap :: [(String, MIMEType)]
133 extMap = [ ("html", read "application/xhtml+xml")
134 , ( "rdf", read "application/rss+xml" )
135 , ( "xml", read "text/xml" )
139 outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource ()
140 outputXmlPage tree formatters
141 = do mType <- getEntityType
143 let formatter = case lookup mType formatters of
146 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
152 writeDocumentToString [ (a_indent, v_1) ]
157 outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
158 outputXmlPage' tree toXHTML
159 = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]
162 getUserID :: Environment -> Resource (Maybe String)
164 = do auth <- getAuthorization
166 Just (BasicAuthCredential userID password)
167 -> do valid <- isValidPair (envAuthDB env) userID password