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 willDiscardBody ← readTVar niWillDiscardBody
  73          canHaveBody     ← if willDiscardBody then
  74                                return False
  75                            else
  76                                resCanHaveBody <$> readTVar niResponse
  77
  78          updateRes ni
  79              $ deleteHeader "Content-Length"
  80              ∘ deleteHeader "Transfer-Encoding"
  81
  82          if canHaveBody then
  83              do when niWillChunkBody $
  84                     writeHeader ni "Transfer-Encoding" (Just "chunked")
  85                 writeDefaultPageIfNeeded ni
  86          else
  87              do writeTVar niWillDiscardBody True
  88                 -- These headers make sense for HEAD requests even
  89                 -- when there won't be a response entity body.
  90                 when (reqMethod niRequest ≢ HEAD)
  91                     $ updateRes ni
  92                     $ deleteHeader "Content-Type"
  93                     ∘ deleteHeader "Etag"
  94                     ∘ deleteHeader "Last-Modified"
  95
  96          hasConnClose ← (≡ Just "close") <$> readCIHeader ni "Connection"
  97          willClose    ← readTVar niWillClose
  98          when (hasConnClose ∧ (¬) willClose)
  99              $ writeTVar niWillClose True
 100          when ((¬) hasConnClose ∧ willClose)
 101              $ writeHeader ni "Connection" (Just "close")
 102
 103 writeDefaultPageIfNeeded ∷ NormalInteraction → STM ()
 104 writeDefaultPageIfNeeded ni@(NI {..})
 105     = do resHasCType ← readTVar niResponseHasCType
 106          unless resHasCType
 107              $ do writeHeader ni "Content-Type" $ Just defaultPageContentType
 108                   writeHeader ni "Content-Encoding" Nothing
 109                   res ← readTVar niResponse
 110                   let body = defaultPageForResponse niConfig (Just niRequest) res
 111                   putTMVar niBodyToSend body
 112
 113 completeUnconditionalHeaders ∷ NormalInteraction → STM ()
 114 completeUnconditionalHeaders ni@(NI {..})
 115     = do srv ← readHeader ni "Server"
 116          when (isNothing srv) $
 117              writeHeader ni "Server" $ Just $ cnfServerSoftware niConfig
 118
 119          date ← readHeader ni "Date"
 120          when (isNothing date) $
 121              do date' ← unsafeIOToSTM getCurrentDate
 122                 writeHeader ni "Date" $ Just date'
 123
 124 writeHeader ∷ NormalInteraction → CIAscii → Maybe Ascii → STM ()
 125 {-# INLINE writeHeader #-}
 126 writeHeader ni k v
 127     = case v of
 128         Just v' → updateRes ni $ setHeader    k v'
 129         Nothing → updateRes ni $ deleteHeader k
 130
 131 readHeader ∷ NormalInteraction → CIAscii → STM (Maybe Ascii)
 132 {-# INLINE readHeader #-}
 133 readHeader (NI {..}) k
 134     = getHeader k <$> readTVar niResponse
 135
 136 readCIHeader ∷ NormalInteraction → CIAscii → STM (Maybe CIAscii)
 137 {-# INLINE readCIHeader #-}
 138 readCIHeader (NI {..}) k
 139     = getCIHeader k <$> readTVar niResponse
 140
 141 updateRes ∷ NormalInteraction → (Response → Response) → STM ()
 142 {-# INLINE updateRes #-}
 143 updateRes (NI {..}) f
 144     = do old ← readTVar niResponse
 145          writeTVar niResponse $ f old