Many changes...

[Lucu.git] / Network / HTTP / Lucu / Resource / Tree.hs

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index d386bce8cd78486a5f89c039a5bf3b5c78ff57a3..092ee06735b8da10b4802f2d9f2423143e998eef 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     DoAndIfThenElse
   , OverloadedStrings
+  , RecordWildCards
   , UnicodeSyntax
   #-}
 {-# OPTIONS_HADDOCK prune #-}
@@ -231,32 +232,30 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri
 
 
 runResource ∷ ResourceDef → Interaction → IO ThreadId
-runResource def itr
-    = def `seq` itr `seq`
-      fork
-      $! catch ( runRes ( do req ← getRequest
-                             fromMaybe notAllowed $ rsrc req
-                             driftTo Done
-                        ) itr
-               )
-               processException
+runResource (ResourceDef {..}) itr@(Interaction {..})
+    = fork $ ( runRes ( do req ← getRequest
+                           fromMaybe notAllowed $ rsrc req
+                           driftTo Done
+                      ) itr
+             )
+             `catch`
+             processException
     where
       fork ∷ IO () → IO ThreadId
-      fork = if resUsesNativeThread def
-             then forkOS
-             else forkIO
+      fork | resUsesNativeThread = forkOS
+           | otherwise           = forkIO
       
       rsrc ∷ Request → Maybe (Resource ())
       rsrc req
           = case reqMethod req of
-              GET    → resGet def
-              HEAD   → case resHead def of
+              GET    → resGet
+              HEAD   → case resHead of
                           Just r  → Just r
-                          Nothing → resGet def
-              POST   → resPost def
-              PUT    → resPut def
-              DELETE → resDelete def
-              _      → undefined
+                          Nothing → resGet
+              POST   → resPost
+              PUT    → resPut
+              DELETE → resDelete
+              _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
 
       notAllowed ∷ Resource ()
       notAllowed
@@ -274,10 +273,11 @@ runResource def itr
                                     , methods resDelete ["DELETE"]
                                     ]
 
-      methods ∷ (ResourceDef → Maybe a) → [Ascii] → [Ascii]
-      methods f xs = case f def of
-                       Just _  → xs
-                       Nothing → []
+      methods ∷ Maybe a → [Ascii] → [Ascii]
+      methods m xs
+          = case m of
+              Just _  → xs
+              Nothing → []
 
       toAbortion ∷ SomeException → Abortion
       toAbortion e
@@ -288,20 +288,19 @@ runResource def itr
       processException ∷ SomeException → IO ()
       processException exc
           = do let abo = toAbortion exc
-                   conf = itrConfig itr
                -- まだ DecidingHeader 以前の状態だったら、この途中終了
                -- を應答に反映させる餘地がある。さうでなければ stderr
                -- にでも吐くしか無い。
-               state ← atomically $ readItr itrState    itr
-               reqM  ← atomically $ readItr itrRequest  itr
-               res   ← atomically $ readItr itrResponse itr
+               state ← atomically $ readTVar itrState
+               reqM  ← atomically $ readTVar itrRequest
+               res   ← atomically $ readTVar itrResponse
                if state ≤ DecidingHeader then
-                   flip runRes itr
-                      $ do setStatus $ aboStatus abo
-                           mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
-                           output $ LT.encodeUtf8 $ abortPage conf reqM res abo
+                   flip runRes itr $
+                       do setStatus $ aboStatus abo
+                          mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
+                          output $ LT.encodeUtf8 $ abortPage itrConfig reqM res abo
                  else
-                   when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
+                   when (cnfDumpTooLateAbortionToStderr itrConfig)
                             $ hPutStrLn stderr $ show abo
 
-               flip runRes itr $ driftTo Done
+               runRes (driftTo Done) itr