Added a configuration flag -fssl to enable SSL support. (default: off)

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

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 704feda9c79ca2e5ab4619b1550166bdd8023f4c..ec3447e7f488585570b4e8891b4da5abdbdad0f0 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    BangPatterns
+    CPP
+  , BangPatterns
   , GeneralizedNewtypeDeriving
   , DoAndIfThenElse
   , OverloadedStrings
@@ -82,7 +83,9 @@ module Network.HTTP.Lucu.Resource
     , getRemoteAddr
     , getRemoteAddr'
     , getRemoteHost
+#if defined(HAVE_SSL)
     , getRemoteCertificate
+#endif
     , getRequest
     , getMethod
     , getRequestURI
@@ -404,9 +407,9 @@ foundETag tag
 
          let statusForNoneMatch
                  = if method ≡ GET ∨ method ≡ HEAD then
-                       NotModified
+                       fromStatusCode NotModified
                    else
-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed
 
          -- If-None-Match があればそれを見る。
          ifNoneMatch ← getHeader "If-None-Match"
@@ -450,15 +453,14 @@ foundTimeStamp timeStamp
          when (method ≡ POST)
              $ abort
              $ mkAbortion' InternalServerError
-               "Illegal computation of foundTimeStamp for POST request."
+               "Illegal call of foundTimeStamp for POST request."
 
          let statusForIfModSince
                  = if method ≡ GET ∨ method ≡ HEAD then
-                       NotModified
+                       fromStatusCode NotModified
                    else
-                       PreconditionFailed
+                       fromStatusCode PreconditionFailed
 
-         -- If-Modified-Since があればそれを見る。
          ifModSince ← getHeader "If-Modified-Since"
          case ifModSince of
            Just str → case HTTP.fromAscii str of
@@ -467,11 +469,11 @@ foundTimeStamp timeStamp
                                $ abort
                                $ mkAbortion' statusForIfModSince
                                $ "The entity has not been modified since " ⊕ A.toText str
-                         Left _
-                             → return () -- 不正な時刻は無視
+                         Left e
+                             → abort $ mkAbortion' BadRequest
+                                     $ "Malformed If-Modified-Since: " ⊕ T.pack e
            Nothing  → return ()
 
-         -- If-Unmodified-Since があればそれを見る。
          ifUnmodSince ← getHeader "If-Unmodified-Since"
          case ifUnmodSince of
            Just str → case HTTP.fromAscii str of
@@ -480,8 +482,9 @@ foundTimeStamp timeStamp
                                $ abort
                                $ mkAbortion' PreconditionFailed
                                $ "The entity has not been modified since " ⊕ A.toText str
-                         Left _
-                             → return () -- 不正な時刻は無視
+                         Left e
+                             → abort $ mkAbortion' BadRequest
+                                     $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
            Nothing  → return ()
 
          driftTo ReceivingBody
@@ -612,16 +615,16 @@ getForm limit
 -- |@'redirect' code uri@ declares the response status as @code@ and
 -- \"Location\" header field as @uri@. The @code@ must satisfy
 -- 'isRedirection' or it raises an error.
-redirect ∷ StatusCode → URI → Resource ()
-redirect code uri
-    = do when (code ≡ NotModified ∨ not (isRedirection code))
+redirect ∷ StatusCode sc ⇒ sc → URI → Resource ()
+redirect sc uri
+    = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
              $ abort
              $ mkAbortion' InternalServerError
              $ A.toText
              $ A.fromAsciiBuilder
              $ A.toAsciiBuilder "Attempted to redirect with status "
-             ⊕ printStatusCode code
-         setStatus code
+             ⊕ printStatusCode sc
+         setStatus sc
          setLocation uri
 
 -- |@'setContentType' mType@ declares the response header