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