]> gitweb @ CieloNegro.org - Rakka.git/blob - Rakka/Resource.hs
StyleSheet/CieloNegro
[Rakka.git] / Rakka / Resource.hs
1 module Rakka.Resource
2     ( runIdempotentA
3     , runXmlA
4     , getEntityType
5     , outputXmlPage
6     , outputXmlPage'
7     , getUserID
8     )
9     where
10
11 import qualified Codec.Binary.UTF8.String as UTF8
12 import           Control.Arrow
13 import           Control.Arrow.ArrowList
14 import           Control.Monad
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.Log.Logger
23 import           Text.XML.HXT.Arrow.ReadDocument
24 import           Text.XML.HXT.Arrow.WriteDocument
25 import           Text.XML.HXT.Arrow.XmlIOStateArrow
26 import           Text.XML.HXT.DOM.TypeDefs
27 import           Text.XML.HXT.DOM.XmlKeywords
28
29
30 logger :: String
31 logger = "Rakka.Resource"
32
33
34 -- "/"         ==> "/"
35 -- "/foo"      ==> "/foo.html"
36 -- "/foo/"     ==> "/foo.html"
37 -- "/foo.bar/" ==> "/foo.bar"
38 -- "/foo.bar"  ==> "/foo.bar"
39 canonicalizeURI :: Resource ()
40 canonicalizeURI 
41     = do uri <- getRequestURI
42          let newURI  = uri { uriPath = "/" ++ joinWith "/" newPath }
43              newPath = case [x | x <- splitBy (== '/') (uriPath uri), x /= ""] of
44                          []   -> []
45                          path -> case break (== '.') $ last path of
46                                    (_, "") -> let basePieces = reverse $ tail $ reverse path
47                                                   lastPiece  = last path
48                                               in
49                                                 basePieces ++ [lastPiece ++ ".html"]
50                                    (_, _)  -> path
51          when (uri /= newURI)
52               $ abort MovedPermanently
53                 [("Location", uriToString id newURI $ "")]
54                 Nothing
55
56
57 runIdempotentA :: IOSArrow () (Resource c) -> Resource c
58 runIdempotentA a
59     = do canonicalizeURI
60          [rsrc] <- liftIO $ runX ( setErrorMsgHandler False fail
61                                    >>>
62                                    constA ()
63                                    >>>
64                                    a
65                                  )
66          rsrc
67
68
69 runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c
70 runXmlA env schemaPath a
71     = do inputA <- getInputXmlA env schemaPath
72          [rsrc] <- liftIO $ runX ( inputA
73                                    >>>
74                                    setErrorMsgHandler False fail
75                                    >>>
76                                    a
77                                  )
78          rsrc
79
80
81 -- well-formed でない時は 400 Bad Request になり、valid でない時は 422
82 -- Unprocessable Entity になる。入力の型が XML でない時は 415
83 -- Unsupported Media Type を返す。
84 getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree)
85 getInputXmlA env schemaPath
86     = do reader    <- getInputReader
87          validator <- getValidator env schemaPath
88          return ( setErrorMsgHandler False (abort BadRequest [] . Just)
89                   >>>
90                   reader
91                   >>>
92                   setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just)
93                   >>>
94                   validator
95                 )
96
97
98 getInputReader :: Resource (IOSArrow b XmlTree)
99 getInputReader 
100     = do mimeType <- getContentType
101          case mimeType of
102            Nothing
103                -> getFailingReader BadRequest [] (Just "Missing Content-Type")
104            Just (MIMEType "text" "xml" _)
105                -> getXmlReader
106            Just (MIMEType "application" "xml" _)
107                -> getXmlReader
108            Just t
109                -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t)
110     where
111       getXmlReader
112           = do req <- input defaultLimit
113                liftIO $ debugM logger req
114                return $ readString [ (a_validate         , v_0)
115                                    , (a_check_namespaces , v_1)
116                                    , (a_remove_whitespace, v_0)
117                                    ] (UTF8.decodeString req)
118       getFailingReader code headers msg
119           = return $ proc _ -> abortA -< (code, (headers, msg))
120
121
122 getEntityType :: Resource MIMEType
123 getEntityType
124     = do uri <- getRequestURI
125          let ext = reverse $ takeWhile (/= '.') $ reverse $ uriPath uri
126          case lookup ext extMap of
127            Just mType -> return mType
128            Nothing    -> abort NotFound [] (Just $ "Unsupported entity type: " ++ ext)
129     where
130       extMap :: [(String, MIMEType)]
131       extMap = [ ("html", read "application/xhtml+xml")
132                , ( "rdf", read "application/rss+xml"  )
133                , ( "xml", read "text/xml"             )
134                ]
135
136
137 outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource ()
138 outputXmlPage tree formatters
139     = do mType <- getEntityType
140          setContentType mType
141          let formatter = case lookup mType formatters of
142                            Just f  -> f
143                            Nothing -> this
144          [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
145                                         >>>
146                                         constA tree
147                                         >>>
148                                         formatter
149                                         >>>
150                                         writeDocumentToString [ (a_indent, v_1) ]
151                                       )
152          output resultStr
153
154
155 outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
156 outputXmlPage' tree toXHTML
157     = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]
158
159
160 getUserID :: Environment -> Resource (Maybe String)
161 getUserID env
162     = do auth <- getAuthorization
163          case auth of
164            Just (BasicAuthCredential userID password)
165                -> do valid <- isValidPair (envAuthDB env) userID password
166                      if valid then
167                          return (Just userID)
168                        else
169                          return Nothing
170            _   -> return Nothing