17 import qualified Codec.Binary.UTF8.String as UTF8
19 import Control.Arrow.ArrowList
20 import Control.Arrow.ListArrow
21 import Control.Arrow.Unicode
23 import Control.Monad.Trans
24 import Data.Monoid.Unicode
25 import qualified Data.Text as T
26 import Network.HTTP.Lucu
27 import Network.HTTP.Lucu.Utils
28 import Network.URI hiding (path)
29 import Prelude.Unicode
30 import Rakka.Authorization
31 import Rakka.Environment
32 import Rakka.Validation
33 import System.FilePath.Posix
34 import System.Log.Logger
35 import Text.XML.HXT.Arrow.ReadDocument
36 import Text.XML.HXT.Arrow.WriteDocument
37 import Text.XML.HXT.DOM.TypeDefs
38 import Text.XML.HXT.Arrow.XmlState
41 logger = "Rakka.Resource"
45 -- "/foo" ==> "/foo.html"
46 -- "/foo/" ==> "/foo.html"
47 -- "/foo.bar/" ==> "/foo.bar"
48 -- "/foo.bar" ==> "/foo.bar"
49 canonicalizeURI :: URI -> Resource ()
50 canonicalizeURI baseURI
51 = do rPath <- return . uriPath =<< getRequestURI
52 let newURI = baseURI { uriPath = uriPath baseURI </> newPath }
53 newPath = foldl (</>) "/" newPath'
54 newPath' = case [x | x <- splitBy (== '/') rPath, x /= ""] of
56 path -> case break (== '.') $ last path of
57 (_, "") -> let basePieces = reverse $ tail $ reverse path
60 basePieces ++ [lastPiece ++ ".html"]
62 when (rPath /= newPath)
63 $ abort MovedPermanently
64 [("Location", uriToString id newURI $ "")]
68 runIdempotentA :: URI -> IOSArrow () (Resource c) -> Resource c
69 runIdempotentA baseURI a
70 = do canonicalizeURI baseURI
71 [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
80 runIdempotentA' :: IOSArrow () (Resource c) -> Resource c
82 = do [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
90 runXmlA ∷ FilePath → IOSArrow XmlTree (Resource c) → Resource c
92 = do inputA ← getInputXmlA schemaPath
93 [rsrc] ← liftIO $ runX ( inputA
95 setErrorMsgHandler False fail
101 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
102 -- Unprocessable Entity になる。入力の型が XML でない時は 415
103 -- Unsupported Media Type を返す。
104 getInputXmlA ∷ FilePath → Resource (IOSArrow b XmlTree)
105 getInputXmlA schemaPath
106 = do reader ← getInputReader
107 validator ← getValidator schemaPath
108 return ( setErrorMsgHandler False (abort BadRequest [] ∘ Just)
112 setErrorMsgHandler False (abort UnprocessableEntitiy [] ∘ Just)
117 getInputReader ∷ Resource (IOSArrow b XmlTree)
119 = do mimeType ← getContentType
122 → getFailingReader BadRequest [] (Just "Missing Content-Type")
123 Just (MIMEType "text" "xml" _)
125 Just (MIMEType "application" "xml" _)
128 → getFailingReader UnsupportedMediaType []
129 (Just $ "Unsupported media type: " ⊕ show t)
132 = do req ← input defaultLimit
133 liftIO $ debugM logger req
134 return $ readString [ withValidate no
135 , withCheckNamespaces yes
137 ] (UTF8.decodeString req)
138 getFailingReader code headers msg
139 = return $ proc _ -> abortA -< (code, (headers, msg))
142 getEntityType :: Resource MIMEType
144 = do uri <- getRequestURI
145 let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
146 case lookup ext extMap of
147 Just mType -> return mType
148 Nothing -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
150 extMap :: [(String, MIMEType)]
151 extMap = [ ("html", read "application/xhtml+xml")
152 , ( "rdf", read "application/rss+xml" )
153 , ( "xml", read "text/xml" )
157 outputXmlPage ∷ XmlTree → [(MIMEType, IOSArrow XmlTree XmlTree)] → Resource ()
158 outputXmlPage tree formatters
159 = do mType ← getEntityType
161 let formatter = case lookup mType formatters of
164 [resultStr] ← liftIO $
165 runX ( setErrorMsgHandler False fail
171 writeDocumentToString
176 output $ UTF8.encodeString resultStr
178 outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
179 outputXmlPage' tree toXHTML
180 = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]
182 outputXml ∷ XmlTree → Resource ()
184 = do setContentType (MIMEType "text" "xml" [])
185 let [xmlStr] = runLA ( writeDocumentToString
190 output $ UTF8.encodeString xmlStr
192 getUserID ∷ Environment → Resource (Maybe String)
194 = do auth ← getAuthorization
196 Just (BasicAuthCredential userID password)
197 → do valid ← isValidPair (envAuthDB env)