code cleanup

[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 e8aa3ef6b555da151896040e3d9640e25e9cec6f..54be5f3934f5755c24a152850e6a8227f5a72146 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
 
@@ -41,6 +44,7 @@ import qualified Data.Ascii as A
 import qualified Data.ByteString as Strict
 import Data.List
 import Data.Maybe
+import Data.Monoid
 import Data.Monoid.Unicode
 import qualified Data.Text as T
 import Network.HTTP.Lucu.Abortion
@@ -52,9 +56,10 @@ import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Postprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Utils
 import Network.Socket
+#if defined(HAVE_SSL)
 import OpenSSL.X509
+#endif
 import Prelude hiding (catch)
 import Prelude.Unicode
 import System.IO
@@ -166,12 +171,12 @@ spawnResource (ResourceDef {..}) ni@(NI {..})
               _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
 
       notAllowed ∷ Resource ()
-      notAllowed
-          = setStatus MethodNotAllowed
-            *>
-            (setHeader "Allow" $ A.fromAsciiBuilder
-                               $ joinWith ", "
-                               $ map A.toAsciiBuilder allowedMethods)
+      notAllowed = do setStatus MethodNotAllowed
+                      setHeader "Allow"
+                          $ A.fromAsciiBuilder
+                          $ mconcat
+                          $ intersperse (A.toAsciiBuilder ", ")
+                          $ map A.toAsciiBuilder allowedMethods
 
       allowedMethods ∷ [Ascii]
       allowedMethods = nub $ concat [ methods resGet    ["GET"]
@@ -230,6 +235,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 +247,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.
@@ -304,14 +311,15 @@ getChunk' n
 
 -- |Declare the response status code. If you don't call this function,
 -- the status code will be defaulted to \"200 OK\".
-setStatus ∷ StatusCode → Resource ()
+setStatus ∷ StatusCode sc ⇒ sc → Resource ()
 setStatus sc
     = do ni ← getInteraction
          liftIO $ atomically
                 $ 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
@@ -329,9 +337,7 @@ setStatus sc
 -- body and thinks that the residual 10 bytes is a part of the header
 -- of the next response.
 setHeader ∷ CIAscii → Ascii → Resource ()
-setHeader name value
-    = do ni ← getInteraction
-         liftIO $ atomically $ go ni
+setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
     where
       go ∷ NormalInteraction → STM ()
       go (NI {..})
@@ -346,9 +352,7 @@ setHeader name value
 -- |@'deleteHeader' name@ deletes a response header @name@ if
 -- any. This function is not intended to be used so frequently.
 deleteHeader ∷ CIAscii → Resource ()
-deleteHeader name
-    = do ni ← getInteraction
-         liftIO $ atomically $ go ni
+deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
     where
       go ∷ NormalInteraction → STM ()
       go (NI {..})
@@ -365,12 +369,10 @@ deleteHeader name
 -- infinitely long stream of octets.
 --
 -- Note that you must first declare the response header
--- \"Content-Type\" before applying this function. See
--- 'setContentType'.
+-- \"Content-Type\" before applying this function. See:
+-- 'setContentType'
 putBuilder ∷ Builder → Resource ()
-putBuilder b
-    = do ni ← getInteraction
-         liftIO $ atomically $ go ni
+putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
     where
       go ∷ NormalInteraction → STM ()
       go ni@(NI {..})
@@ -383,9 +385,7 @@ putBuilder b
                putTMVar niBodyToSend b
 
 driftTo ∷ InteractionState → Resource ()
-driftTo newState
-    = do ni ← getInteraction
-         liftIO $ atomically $ driftTo' ni newState
+driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
 
 driftTo' ∷ NormalInteraction → InteractionState → STM ()
 driftTo' ni@(NI {..}) newState