X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FPostprocess.hs;h=4ba7865d466f499a11d6a5f86c133bfc34b705f4;hb=bb41be0c967538a1014c87103a3a5d3840ad3e15;hp=6735652d6a5656410c6cc5ebfcdc922c11184761;hpb=3eb69879d3b336c7c3e613c0ce4bfb3c67989ff3;p=Lucu.git diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 6735652..4ba7865 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -13,7 +13,7 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii, AsciiBuilder) -import qualified Data.Ascii as A +import Data.Convertible.Base import Data.Maybe import Data.Monoid.Unicode import GHC.Conc (unsafeIOToSTM) @@ -44,29 +44,28 @@ abortOnCertainConditions (NI {..}) , isError ]) $ abort' - $ A.toAsciiBuilder "Inappropriate status code for a response: " - ⊕ printStatusCode resStatus + $ cs ("Inappropriate status code for a response: " ∷ Ascii) + ⊕ cs resStatus - when ( resStatus ≡ MethodNotAllowed ∧ + when ( resStatus ≈ MethodNotAllowed ∧ hasHeader "Allow" res ) $ abort' - $ A.toAsciiBuilder "The status was " - ⊕ printStatusCode resStatus - ⊕ A.toAsciiBuilder " but no \"Allow\" header." + $ cs ("The status was " ∷ Ascii) + ⊕ cs resStatus + ⊕ cs (" but no \"Allow\" header." ∷ Ascii) - when ( resStatus ≢ NotModified ∧ - isRedirection resStatus ∧ + when ( resStatus ≉ NotModified ∧ + isRedirection resStatus ∧ hasHeader "Location" res ) $ abort' - $ A.toAsciiBuilder "The status code was " - ⊕ printStatusCode resStatus - ⊕ A.toAsciiBuilder " but no Location header." + $ cs ("The status code was " ∷ Ascii) + ⊕ cs resStatus + ⊕ cs (" but no Location header." ∷ Ascii) abort' ∷ AsciiBuilder → STM () abort' = throwSTM ∘ mkAbortion' InternalServerError - ∘ A.toText - ∘ A.fromAsciiBuilder + ∘ cs postprocessWithRequest ∷ NormalInteraction → STM () postprocessWithRequest ni@(NI {..}) @@ -108,7 +107,7 @@ writeDefaultPageIfNeeded ni@(NI {..}) $ do writeHeader ni "Content-Type" $ Just defaultPageContentType writeHeader ni "Content-Encoding" Nothing res ← readTVar niResponse - let body = getDefaultPage niConfig (Just niRequest) res + let body = defaultPageForResponse niConfig (Just niRequest) res putTMVar niBodyToSend body completeUnconditionalHeaders ∷ NormalInteraction → STM ()