auto-derive Map

[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 e066fa9074e8eaf4173ce60f715dc2b2bbdb3bdd..f8ea1b2aaf5b3b35edad73d7b3da2731d4b08d18 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    DoAndIfThenElse
+    CPP
+  , DoAndIfThenElse
   , GeneralizedNewtypeDeriving
   , OverloadedStrings
   , RecordWildCards
@@ -13,7 +14,9 @@ module Network.HTTP.Lucu.Resource.Internal
 
     , getConfig
     , getRemoteAddr
+#if defined(HAVE_SSL)
     , getRemoteCertificate
+#endif
     , getRequest
     , getResourcePath
 
@@ -33,13 +36,15 @@ import Control.Applicative
 import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
+import Control.Monad hiding (mapM_)
 import Control.Monad.IO.Class
-import Control.Monad.Reader
+import Control.Monad.Reader (ReaderT, runReaderT, ask)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString as Strict
-import Data.List
+import Data.Collections
+import Data.List (intersperse, nub)
 import Data.Maybe
 import Data.Monoid
 import Data.Monoid.Unicode
@@ -54,8 +59,10 @@ import Network.HTTP.Lucu.Postprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.Socket
+#if defined(HAVE_SSL)
 import OpenSSL.X509
-import Prelude hiding (catch)
+#endif
+import Prelude hiding (catch, concat, mapM_, tail)
 import Prelude.Unicode
 import System.IO
 
@@ -202,7 +209,7 @@ spawnResource (ResourceDef {..}) ni@(NI {..})
                    -- in the response. Hooray!
                    flip runResource ni $
                        do setStatus $ aboStatus abo
-                          mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
+                          mapM_ (uncurry setHeader) (aboHeaders abo)
                           setHeader "Content-Type" defaultPageContentType
                           deleteHeader "Content-Encoding"
                           putBuilder $ abortPage niConfig (Just niRequest) res abo
@@ -230,6 +237,7 @@ getConfig = niConfig <$> getInteraction
 getRemoteAddr ∷ Resource SockAddr
 getRemoteAddr = niRemoteAddr <$> getInteraction
 
+#if defined(HAVE_SSL)
 -- | Return the X.509 certificate of the client, or 'Nothing' if:
 --
 --   * This request didn't came through an SSL stream.
@@ -241,6 +249,7 @@ getRemoteAddr = niRemoteAddr <$> getInteraction
 --   'OpenSSL.Session.VerifyPeer'.
 getRemoteCertificate ∷ Resource (Maybe X509)
 getRemoteCertificate = niRemoteCert <$> getInteraction
+#endif
 
 -- |Return the 'Request' value representing the request header. You
 -- usually don't need to call this function directly.
@@ -311,7 +320,8 @@ setStatus sc
                 $ do state ← readTVar $ niState ni
                      when (state > DecidingHeader)
                          $ fail "Too late to declare the response status."
-                     setResponseStatus ni sc
+                     res ← readTVar $ niResponse ni
+                     writeTVar (niResponse ni) $ setStatusCode sc res
 
 -- |@'setHeader' name value@ declares the value of the response header
 -- @name@ as @value@. Note that this function is not intended to be
@@ -366,6 +376,7 @@ deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
 putBuilder ∷ Builder → Resource ()
 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
     where
+      -- FIXME: should see if resCanHaveBody.
       go ∷ NormalInteraction → STM ()
       go ni@(NI {..})
           = do driftTo' ni SendingBody