Fix a long-standing bug in generating Allowed header values.

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

diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index a19339c1e6280e3830987bab5a9d200002ad6344..7398f93e045cff87dd51b1241e23b0da70bcd3ca 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -38,19 +38,20 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad hiding (mapM_)
+import Control.Monad.Fix
 import Control.Monad.IO.Class
 import Control.Monad.Reader (ReaderT, runReaderT, ask)
 import Control.Monad.Unicode
-import Data.Ascii (Ascii, CIAscii)
-import qualified Data.Ascii as A
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
 import Data.List (intersperse, nub)
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
-import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
 import Network.HTTP.Lucu.Abortion.Internal
 import Network.HTTP.Lucu.Config
@@ -60,6 +61,7 @@ import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Postprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Response.StatusCode
 import Network.HTTP.Lucu.Utils
 import Network.Socket
 #if defined(HAVE_SSL)
@@ -75,7 +77,7 @@ newtype Rsrc a
     = Rsrc {
         unRsrc ∷ ReaderT NormalInteraction IO a
       }
-    deriving (Applicative, Functor, Monad, MonadIO)
+    deriving (Applicative, Functor, Monad, MonadFix, MonadIO)
 
 runRsrc ∷ Rsrc a → NormalInteraction → IO a
 runRsrc = runReaderT ∘ unRsrc
@@ -179,14 +181,14 @@ spawnRsrc (Resource {..}) ni@(NI {..})
       notAllowed ∷ Rsrc ()
       notAllowed = do setStatus MethodNotAllowed
                       setHeader "Allow"
-                          $ A.fromAsciiBuilder
+                          $ cs
                           $ mconcat
-                          $ intersperse (A.toAsciiBuilder ", ")
-                          $ map A.toAsciiBuilder allowedMethods
+                          $ intersperse (cs (", " ∷ Ascii) ∷ AsciiBuilder)
+                          $ map cs allowedMethods
 
       allowedMethods ∷ [Ascii]
-      allowedMethods = nub $ concat [ methods resGet    ["GET"]
-                                    , methods resHead   ["GET", "HEAD"]
+      allowedMethods = nub $ concat [ methods resGet    ["GET", "HEAD"]
+                                    , methods resHead   ["HEAD"]
                                     , methods resPost   ["POST"]
                                     , methods resPut    ["PUT"]
                                     , methods resDelete ["DELETE"]
@@ -201,7 +203,7 @@ spawnRsrc (Resource {..}) ni@(NI {..})
       toAbortion e
           = case fromException e of
               Just abortion → abortion
-              Nothing       → mkAbortion' InternalServerError $ T.pack $ show e
+              Nothing       → mkAbortion' InternalServerError $ cs $ show e
 
       processException ∷ SomeException → IO ()
       processException exc
@@ -301,7 +303,7 @@ getChunk' n
     | n < 0     = fail ("getChunk: n must not be negative: " ⧺ show n)
     | n ≡ 0     = return (∅)
     | otherwise = do req ← getRequest
-                     if reqMustHaveBody req then
+                     if reqHasBody req then
                          askForInput =≪ getInteraction
                      else
                          driftTo DecidingHeader *> return (∅)