Network/HTTP/Lucu/Postprocess.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , OverloadedStrings
   4   , RecordWildCards
   5   , UnicodeSyntax
   6   #-}
   7 module Network.HTTP.Lucu.Postprocess
   8     ( postprocess
   9     )
  10     where
  11 import Control.Applicative
  12 import Control.Concurrent.STM
  13 import Control.Monad
  14 import Control.Monad.Unicode
  15 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
  16 import Data.Convertible.Base
  17 import Data.Maybe
  18 import Data.Monoid.Unicode
  19 import GHC.Conc (unsafeIOToSTM)
  20 import Network.HTTP.Lucu.Abortion
  21 import Network.HTTP.Lucu.Config
  22 import Network.HTTP.Lucu.DefaultPage
  23 import Network.HTTP.Lucu.Headers
  24 import Network.HTTP.Lucu.Interaction
  25 import Network.HTTP.Lucu.Request
  26 import Network.HTTP.Lucu.Response
  27 import Prelude.Unicode
  28
  29 postprocess ∷ NormalInteraction → STM ()
  30 postprocess ni@(NI {..})
  31     = do void $ tryPutTMVar niSendContinue False
  32          abortOnCertainConditions ni
  33          postprocessWithRequest ni
  34          completeUnconditionalHeaders ni
  35
  36 abortOnCertainConditions ∷ NormalInteraction → STM ()
  37 abortOnCertainConditions (NI {..})
  38     = readTVar niResponse ≫= go
  39     where
  40       go ∷ Response → STM ()
  41       go res@(Response {..})
  42           = do unless (any (\ p → p resStatus) [ isSuccessful
  43                                                , isRedirection
  44                                                , isError
  45                                                ])
  46                    $ abort'
  47                    $ cs ("Inappropriate status code for a response: " ∷ Ascii)
  48                    ⊕ cs resStatus
  49
  50                when ( resStatus ≈ MethodNotAllowed ∧
  51                       hasHeader "Allow" res        )
  52                    $ abort'
  53                    $ cs ("The status was " ∷ Ascii)
  54                    ⊕ cs resStatus
  55                    ⊕ cs (" but no \"Allow\" header." ∷ Ascii)
  56
  57                when ( resStatus ≉ NotModified  ∧
  58                       isRedirection resStatus  ∧
  59                       hasHeader "Location" res )
  60                    $ abort'
  61                    $ cs ("The status code was " ∷ Ascii)
  62                    ⊕ cs resStatus
  63                    ⊕ cs (" but no Location header." ∷ Ascii)
  64
  65       abort' ∷ AsciiBuilder → STM ()
  66       abort' = throwSTM
  67                ∘ mkAbortion' InternalServerError
  68                ∘ cs
  69
  70 postprocessWithRequest ∷ NormalInteraction → STM ()
  71 postprocessWithRequest ni@(NI {..})
  72     = do updateRes ni
  73              $ deleteHeader "Content-Length"
  74              ∘ deleteHeader "Transfer-Encoding"
  75
  76          canHaveBody ← resCanHaveBody <$> readTVar niResponse
  77          if canHaveBody then
  78              do when niWillChunkBody
  79                     $ writeHeader ni "Transfer-Encoding" (Just "chunked")
  80                 when (reqMethod niRequest ≢ HEAD)
  81                     $ writeDefaultPageIfNeeded ni
  82          else
  83              -- These headers make sense for HEAD requests even when
  84              -- there won't be a response entity body.
  85              when (reqMethod niRequest ≢ HEAD)
  86                  $ updateRes ni
  87                  $ deleteHeader "Content-Type"
  88                  ∘ deleteHeader "Etag"
  89                  ∘ deleteHeader "Last-Modified"
  90
  91          hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
  92          willClose    ← readTVar niWillClose
  93          when (hasConnClose ∧ (¬) willClose)
  94              $ writeTVar niWillClose True
  95          when ((¬) hasConnClose ∧ willClose)
  96              $ writeHeader ni "Connection" (Just "close")
  97
  98 writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
  99 writeDefaultPageIfNeeded ni@(NI {..})
 100     = do resHasCType ← readTVar niResponseHasCType
 101          unless resHasCType
 102              $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
 103                   writeHeader ni "Content-Encoding" Nothing
 104                   res ← readTVar niResponse
 105                   let body = defaultPageForResponse niConfig (Just niRequest) res
 106                   putTMVar niBodyToSend body
 107
 108 completeUnconditionalHeaders ∷ NormalInteraction → STM ()
 109 completeUnconditionalHeaders ni@(NI {..})
 110     = do srv ← readHeader ni "Server"
 111          when (isNothing srv) $
 112              writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
 113
 114          date ← readHeader ni "Date"
 115          when (isNothing date) $
 116              do date' ← unsafeIOToSTM getCurrentDate
 117                 writeHeader ni "Date" $ Just date'
 118
 119 writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()
 120 {-# INLINE writeHeader #-}
 121 writeHeader ni k v
 122     = case v of
 123         Just v' → updateRes ni $ setHeader    k v'
 124         Nothing → updateRes ni $ deleteHeader k
 125
 126 readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
 127 {-# INLINE readHeader #-}
 128 readHeader (NI {..}) k
 129     = getHeader k <$> readTVar niResponse
 130
 131 readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
 132 {-# INLINE readCIHeader #-}
 133 readCIHeader (NI {..}) k
 134     = getCIHeader k <$> readTVar niResponse
 135
 136 updateRes ∷ NormalInteraction → (Response → Response) → STM ()
 137 {-# INLINE updateRes #-}
 138 updateRes (NI {..}) f
 139     = do old ← readTVar niResponse
 140          writeTVar niResponse $ f old