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