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 qualified Data.Ascii as A
  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                    $ A.toAsciiBuilder "Inappropriate status code for a response: "
  48                    ⊕ printStatusCode resStatus
  49
  50                when ( resStatus ≈ MethodNotAllowed ∧
  51                       hasHeader "Allow" res        )
  52                    $ abort'
  53                    $ A.toAsciiBuilder "The status was "
  54                    ⊕ printStatusCode resStatus
  55                    ⊕ A.toAsciiBuilder " but no \"Allow\" header."
  56
  57                when ( resStatus ≉ NotModified  ∧
  58                       isRedirection resStatus  ∧
  59                       hasHeader "Location" res )
  60                    $ abort'
  61                    $ A.toAsciiBuilder "The status code was "
  62                    ⊕ printStatusCode resStatus
  63                    ⊕ A.toAsciiBuilder " but no Location header."
  64
  65       abort' ∷ AsciiBuilder → STM ()
  66       abort' = throwSTM
  67                ∘ mkAbortion' InternalServerError
  68                ∘ A.toText
  69                ∘ A.fromAsciiBuilder
  70
  71 postprocessWithRequest ∷ NormalInteraction → STM ()
  72 postprocessWithRequest ni@(NI {..})
  73     = do willDiscardBody ← readTVar niWillDiscardBody
  74          canHaveBody     ← if willDiscardBody then
  75                                return False
  76                            else
  77                                resCanHaveBody <$> readTVar niResponse
  78
  79          updateRes ni
  80              $ deleteHeader "Content-Length"
  81              ∘ deleteHeader "Transfer-Encoding"
  82
  83          if canHaveBody then
  84              do when niWillChunkBody $
  85                     writeHeader ni "Transfer-Encoding" (Just "chunked")
  86                 writeDefaultPageIfNeeded ni
  87          else
  88              do writeTVar niWillDiscardBody True
  89                 -- These headers make sense for HEAD requests even
  90                 -- when there won't be a response entity body.
  91                 when (reqMethod niRequest ≢ HEAD)
  92                     $ updateRes ni
  93                     $ deleteHeader "Content-Type"
  94                     ∘ deleteHeader "Etag"
  95                     ∘ deleteHeader "Last-Modified"
  96
  97          hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
  98          willClose    ← readTVar niWillClose
  99          when (hasConnClose ∧ (¬) willClose)
 100              $ writeTVar niWillClose True
 101          when ((¬) hasConnClose ∧ willClose)
 102              $ writeHeader ni "Connection" (Just "close")
 103
 104 writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
 105 writeDefaultPageIfNeeded ni@(NI {..})
 106     = do resHasCType ← readTVar niResponseHasCType
 107          unless resHasCType
 108              $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
 109                   writeHeader ni "Content-Encoding" Nothing
 110                   res ← readTVar niResponse
 111                   let body = getDefaultPage niConfig (Just niRequest) res
 112                   putTMVar niBodyToSend body
 113
 114 completeUnconditionalHeaders ∷ NormalInteraction → STM ()
 115 completeUnconditionalHeaders ni@(NI {..})
 116     = do srv ← readHeader ni "Server"
 117          when (isNothing srv) $
 118              writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
 119
 120          date ← readHeader ni "Date"
 121          when (isNothing date) $
 122              do date' ← unsafeIOToSTM getCurrentDate
 123                 writeHeader ni "Date" $ Just date'
 124
 125 writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()
 126 {-# INLINE writeHeader #-}
 127 writeHeader ni k v
 128     = case v of
 129         Just v' → updateRes ni $ setHeader    k v'
 130         Nothing → updateRes ni $ deleteHeader k
 131
 132 readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
 133 {-# INLINE readHeader #-}
 134 readHeader (NI {..}) k
 135     = getHeader k <$> readTVar niResponse
 136
 137 readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
 138 {-# INLINE readCIHeader #-}
 139 readCIHeader (NI {..}) k
 140     = getCIHeader k <$> readTVar niResponse
 141
 142 updateRes ∷ NormalInteraction → (Response → Response) → STM ()
 143 {-# INLINE updateRes #-}
 144 updateRes (NI {..}) f
 145     = do old ← readTVar niResponse
 146          writeTVar niResponse $ f old