3 , GeneralizedNewtypeDeriving
8 module Network.HTTP.Lucu.Resource.Internal
27 import Blaze.ByteString.Builder (Builder)
28 import Control.Applicative
29 import Control.Concurrent
30 import Control.Concurrent.STM
31 import Control.Exception
32 import Control.Monad.IO.Class
33 import Control.Monad.Reader
34 import Data.Ascii (Ascii, CIAscii)
35 import qualified Data.Ascii as A
38 import Data.Monoid.Unicode
39 import qualified Data.Text as T
40 import Network.HTTP.Lucu.Abortion
41 import Network.HTTP.Lucu.Config
42 import Network.HTTP.Lucu.DefaultPage
43 import qualified Network.HTTP.Lucu.Headers as H
44 import Network.HTTP.Lucu.Interaction
45 import Network.HTTP.Lucu.Postprocess
46 import Network.HTTP.Lucu.Request
47 import Network.HTTP.Lucu.Response
48 import Network.HTTP.Lucu.Utils
49 import Prelude hiding (catch)
50 import Prelude.Unicode
53 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
57 unResource ∷ ReaderT Interaction IO a
59 deriving (Applicative, Functor, Monad, MonadIO)
61 runResource ∷ Resource a → Interaction → IO a
62 runResource = runReaderT ∘ unResource
64 -- | 'ResourceDef' is basically a set of 'Resource' monads for each
66 data ResourceDef = ResourceDef {
67 -- |Whether to run a 'Resource' on a native thread (spawned by
68 -- 'forkOS') or to run it on a user thread (spanwed by
69 -- 'forkIO'). Generally you don't need to set this field to
71 resUsesNativeThread ∷ !Bool
72 -- | Whether to be greedy or not.
74 -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
75 -- greedy resource at \/aaa\/bbb, it is always chosen even if
76 -- there is another resource at \/aaa\/bbb\/ccc. If the resource
77 -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
78 -- resources are like CGI scripts.
80 -- | A 'Resource' to be run when a GET request comes for the
81 -- resource path. If 'resGet' is Nothing, the system responds
82 -- \"405 Method Not Allowed\" for GET requests.
84 -- It also runs for HEAD request if the 'resHead' is Nothing. In
85 -- this case 'output' and such like don't actually write a
87 , resGet ∷ !(Maybe (Resource ()))
88 -- | A 'Resource' to be run when a HEAD request comes for the
89 -- resource path. If 'resHead' is Nothing, the system runs
90 -- 'resGet' instead. If 'resGet' is also Nothing, the system
91 -- responds \"405 Method Not Allowed\" for HEAD requests.
92 , resHead ∷ !(Maybe (Resource ()))
93 -- | A 'Resource' to be run when a POST request comes for the
94 -- resource path. If 'resPost' is Nothing, the system responds
95 -- \"405 Method Not Allowed\" for POST requests.
96 , resPost ∷ !(Maybe (Resource ()))
97 -- | A 'Resource' to be run when a PUT request comes for the
98 -- resource path. If 'resPut' is Nothing, the system responds
99 -- \"405 Method Not Allowed\" for PUT requests.
100 , resPut ∷ !(Maybe (Resource ()))
101 -- | A 'Resource' to be run when a DELETE request comes for the
102 -- resource path. If 'resDelete' is Nothing, the system responds
103 -- \"405 Method Not Allowed\" for DELETE requests.
104 , resDelete ∷ !(Maybe (Resource ()))
107 -- |'emptyResource' is a resource definition with no actual
108 -- handlers. You can construct a 'ResourceDef' by selectively
109 -- overriding 'emptyResource'. It is defined as follows:
112 -- emptyResource = ResourceDef {
113 -- resUsesNativeThread = False
114 -- , resIsGreedy = False
115 -- , resGet = Nothing
116 -- , resHead = Nothing
117 -- , resPost = Nothing
118 -- , resPut = Nothing
119 -- , resDelete = Nothing
122 emptyResource ∷ ResourceDef
123 emptyResource = ResourceDef {
124 resUsesNativeThread = False
125 , resIsGreedy = False
130 , resDelete = Nothing
133 spawnResource ∷ ResourceDef → Interaction → IO ThreadId
134 spawnResource (ResourceDef {..}) itr@(Interaction {..})
135 = fork $ run `catch` processException
137 fork ∷ IO () → IO ThreadId
138 fork | resUsesNativeThread = forkOS
142 run = flip runResource itr $
144 fromMaybe notAllowed $ rsrc req
147 rsrc ∷ Request → Maybe (Resource ())
149 = case reqMethod req of
151 HEAD → case resHead of
157 _ → error $ "Unknown request method: " ⧺ show (reqMethod req)
159 notAllowed ∷ Resource ()
161 = setStatus MethodNotAllowed
163 (setHeader "Allow" $ A.fromAsciiBuilder
165 $ map A.toAsciiBuilder allowedMethods)
167 allowedMethods ∷ [Ascii]
168 allowedMethods = nub $ concat [ methods resGet ["GET"]
169 , methods resHead ["GET", "HEAD"]
170 , methods resPost ["POST"]
171 , methods resPut ["PUT"]
172 , methods resDelete ["DELETE"]
175 methods ∷ Maybe a → [Ascii] → [Ascii]
180 toAbortion ∷ SomeException → Abortion
182 = case fromException e of
183 Just abortion → abortion
184 Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
186 processException ∷ SomeException → IO ()
188 = do let abo = toAbortion exc
189 -- まだ DecidingHeader 以前の状態だったら、この途中終了
190 -- を應答に反映させる餘地がある。さうでなければ stderr
192 state ← atomically $ readTVar itrState
193 res ← atomically $ readTVar itrResponse
194 if state ≤ DecidingHeader then
195 flip runResource itr $
196 do setStatus $ aboStatus abo
197 setHeader "Content-Type" defaultPageContentType
198 deleteHeader "Content-Encoding"
199 mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
200 putBuilder $ abortPage itrConfig itrRequest res abo
202 when (cnfDumpTooLateAbortionToStderr itrConfig)
204 runResource (driftTo Done) itr
206 dumpAbortion ∷ Abortion → IO ()
209 $ concat [ "Lucu: an exception occured after "
210 , "sending response header to the client:\n"
211 , " ", show abo, "\n"
214 getInteraction ∷ Resource Interaction
215 getInteraction = Resource ask
217 -- |Get the 'Request' value which represents the request header. In
218 -- general you don't have to use this action.
219 getRequest ∷ Resource Request
220 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
222 -- | Set the response status code. If you don't call this function,
223 -- the status code will be defaulted to \"200 OK\".
224 setStatus ∷ StatusCode → Resource ()
226 = do driftTo DecidingHeader
230 $ setResponseStatus itr sc
232 -- | @'setHeader' name value@ sets the value of the response header
233 -- @name@ to @value@. Note that this function is not intended to be
234 -- used so frequently: there should be specialised functions like
235 -- 'setContentType' for every common headers.
237 -- Some important headers (especially \"Content-Length\" and
238 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
239 -- the system not to corrupt the interaction with client at the
240 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
241 -- the connection alive, without this manipulation it will be a
242 -- catastrophe when we send a header \"Content-Length: 10\" and
243 -- actually send a body of 20 bytes long to the remote peer. In this
244 -- case the client shall only accept the first 10 bytes of response
245 -- body and thinks that the residual 10 bytes is a part of the header
246 -- of the next response.
247 setHeader ∷ CIAscii → Ascii → Resource ()
249 = driftTo DecidingHeader *> setHeader' name value
251 setHeader' ∷ CIAscii → Ascii → Resource ()
252 setHeader' name value
253 = do itr ← getInteraction
255 $ do res ← readTVar $ itrResponse itr
256 let res' = H.setHeader name value res
257 writeTVar (itrResponse itr) res'
258 when (name ≡ "Content-Type")
259 $ writeTVar (itrResponseHasCType itr) True
261 -- | @'deleteHeader' name@ deletes a response header @name@ if
262 -- any. This function is not intended to be used so frequently.
263 deleteHeader ∷ CIAscii → Resource ()
265 = driftTo DecidingHeader *> deleteHeader' name
267 deleteHeader' ∷ CIAscii → Resource ()
269 = do itr ← getInteraction
271 $ do res ← readTVar $ itrResponse itr
272 let res' = H.deleteHeader name res
273 writeTVar (itrResponse itr) res'
274 when (name ≡ "Content-Type")
275 $ writeTVar (itrResponseHasCType itr) False
277 -- | Run a 'Builder' to construct a chunk, and write it to the
278 -- response body. It is safe to apply this function to a 'Builder'
279 -- producing an infinitely long stream of octets.
281 -- Note that you must first set the response header \"Content-Type\"
282 -- before applying this function. See: 'setContentType'
283 putBuilder ∷ Builder → Resource ()
285 = do itr ← getInteraction
287 $ do driftTo' itr DecidingBody
288 hasCType ← readTVar $ itrResponseHasCType itr
290 $ abortSTM InternalServerError []
291 $ Just "putBuilder: Content-Type has not been set."
292 putTMVar (itrBodyToSend itr) b
294 driftTo ∷ InteractionState → Resource ()
296 = do itr ← getInteraction
297 liftIO $ atomically $ driftTo' itr newState
299 driftTo' ∷ Interaction → InteractionState → STM ()
300 driftTo' itr@(Interaction {..}) newState
301 = do oldState ← readTVar itrState
302 if newState < oldState then
303 throwStateError oldState newState
305 do let a = [oldState .. newState]
308 mapM_ (uncurry drift) c
309 writeTVar itrState newState
311 throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
312 throwStateError Done DecidingBody
313 = fail "It makes no sense to output something after finishing outputs."
314 throwStateError old new
315 = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
317 drift ∷ InteractionState → InteractionState → STM ()
319 = putTMVar itrGetBodyRequest WasteAll
320 drift DecidingHeader _