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     , completeUnconditionalHeaders
  10     )
  11     where
  12 import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
  13 import Control.Applicative
  14 import Control.Concurrent.STM
  15 import Control.Monad
  16 import Control.Monad.Unicode
  17 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
  18 import qualified Data.Ascii as A
  19 import Data.Monoid.Unicode
  20 import Data.Time
  21 import qualified Data.Time.HTTP as HTTP
  22 import GHC.Conc (unsafeIOToSTM)
  23 import Network.HTTP.Lucu.Abortion
  24 import Network.HTTP.Lucu.Config
  25 import Network.HTTP.Lucu.DefaultPage
  26 import Network.HTTP.Lucu.Headers
  27 import Network.HTTP.Lucu.HttpVersion
  28 import Network.HTTP.Lucu.Interaction
  29 import Network.HTTP.Lucu.Request
  30 import Network.HTTP.Lucu.Response
  31 import Prelude.Unicode
  32
  33 postprocess ∷ Interaction → STM ()
  34 postprocess itr@(Interaction {..})
  35     = do abortOnCertainConditions itr
  36          writeDefaultPageIfNeeded itr
  37
  38          case itrRequest of
  39            Just req → postprocessWithRequest itr req
  40            Nothing  → return ()
  41
  42          updateResIO itr $ completeUnconditionalHeaders itrConfig
  43
  44 abortOnCertainConditions ∷ Interaction → STM ()
  45 abortOnCertainConditions (Interaction {..})
  46     = readTVar itrResponse ≫= go
  47     where
  48       go ∷ Response → STM ()
  49       go res@(Response {..})
  50           = do unless (any (\ p → p resStatus) [ isSuccessful
  51                                                , isRedirection
  52                                                , isError
  53                                                ])
  54                    $ abort'
  55                    $ A.toAsciiBuilder "Inappropriate status code for a response: "
  56                    ⊕ printStatusCode resStatus
  57
  58                when ( resStatus ≡ MethodNotAllowed ∧
  59                       hasHeader "Allow" res        )
  60                    $ abort'
  61                    $ A.toAsciiBuilder "The status was "
  62                    ⊕ printStatusCode resStatus
  63                    ⊕ A.toAsciiBuilder " but no \"Allow\" header."
  64
  65                when ( resStatus ≢ NotModified  ∧
  66                       isRedirection resStatus ∧
  67                       hasHeader "Location" res )
  68                    $ abort'
  69                    $ A.toAsciiBuilder "The status code was "
  70                    ⊕ printStatusCode resStatus
  71                    ⊕ A.toAsciiBuilder " but no Location header."
  72
  73       abort' ∷ AsciiBuilder → STM ()
  74       abort' = abortSTM InternalServerError []
  75                ∘ Just
  76                ∘ A.toText
  77                ∘ A.fromAsciiBuilder
  78
  79 postprocessWithRequest ∷ Interaction → Request → STM ()
  80 postprocessWithRequest itr@(Interaction {..}) (Request {..})
  81     = do willDiscardBody ← readTVar itrWillDiscardBody
  82          canHaveBody     ← if willDiscardBody then
  83                                return False
  84                            else
  85                                resCanHaveBody <$> readTVar itrResponse
  86
  87          updateRes itr
  88              $ deleteHeader "Content-Length"
  89              ∘ deleteHeader "Transfer-Encoding"
  90
  91          if canHaveBody then
  92              do when (reqVersion ≡ HttpVersion 1 1)
  93                     $ do writeHeader itr "Transfer-Encoding" (Just "chunked")
  94                          writeTVar itrWillChunkBody True
  95                 writeDefaultPageIfNeeded itr
  96          else
  97              do writeTVar itrWillDiscardBody True
  98                 -- These headers make sense for HEAD requests even
  99                 -- when there won't be a response entity body.
 100                 when (reqMethod ≢ HEAD)
 101                     $ updateRes itr
 102                     $ deleteHeader "Content-Type"
 103                     ∘ deleteHeader "Etag"
 104                     ∘ deleteHeader "Last-Modified"
 105
 106          hasConnClose ← (≡ Just "close") <$> readCIHeader itr "Connection"
 107          willClose    ← readTVar itrWillClose
 108          when (hasConnClose ∧ (¬) willClose)
 109              $ writeTVar itrWillClose True
 110          when ((¬) hasConnClose ∧ willClose)
 111              $ writeHeader itr "Connection" (Just "close")
 112
 113 writeDefaultPageIfNeeded ∷ Interaction → STM ()
 114 writeDefaultPageIfNeeded itr@(Interaction {..})
 115     = do resHasCType ← readTVar itrResponseHasCType
 116          unless resHasCType
 117              $ do writeHeader itr "Content-Type" (Just defaultPageContentType)
 118                   res ← readTVar itrResponse
 119                   let page = getDefaultPage itrConfig itrRequest res
 120                   putTMVar itrBodyToSend (BB.fromLazyText page)
 121
 122 writeHeader ∷ Interaction → CIAscii → Maybe Ascii → STM ()
 123 {-# INLINE writeHeader #-}
 124 writeHeader itr k v
 125     = case v of
 126         Just v' → updateRes itr $ setHeader    k v'
 127         Nothing → updateRes itr $ deleteHeader k
 128
 129 readCIHeader ∷ Interaction → CIAscii → STM (Maybe CIAscii)
 130 {-# INLINE readCIHeader #-}
 131 readCIHeader (Interaction {..}) k
 132     = getCIHeader k <$> readTVar itrResponse
 133
 134 updateRes ∷ Interaction → (Response → Response) → STM ()
 135 {-# INLINE updateRes #-}
 136 updateRes (Interaction {..}) f
 137     = do old ← readTVar itrResponse
 138          writeTVar itrResponse (f old)
 139
 140 updateResIO ∷ Interaction → (Response → IO Response) → STM ()
 141 {-# INLINE updateResIO #-}
 142 updateResIO (Interaction {..}) f
 143     = do old ← readTVar itrResponse
 144          new ← unsafeIOToSTM $ f old
 145          writeTVar itrResponse new
 146
 147 completeUnconditionalHeaders ∷ Config → Response → IO Response
 148 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
 149       where
 150         compServer res'
 151             = case getHeader "Server" res' of
 152                 Nothing → return $ setHeader "Server" (cnfServerSoftware conf) res'
 153                 Just _  → return res'
 154
 155         compDate res'
 156             = case getHeader "Date" res' of
 157                 Nothing → do date ← getCurrentDate
 158                              return $ setHeader "Date" date res'
 159                 Just _  → return res'
 160
 161 getCurrentDate ∷ IO Ascii
 162 getCurrentDate = HTTP.toAscii <$> getCurrentTime