Network/HTTP/Lucu/Resource/Internal.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , GeneralizedNewtypeDeriving
   4   , OverloadedStrings
   5   , RecordWildCards
   6   , UnicodeSyntax
   7   #-}
   8 module Network.HTTP.Lucu.Resource.Internal
   9     ( Resource
  10     , ResourceDef(..)
  11     , emptyResource
  12     , spawnResource
  13
  14     , getInteraction
  15     , getRequest
  16
  17     , setStatus
  18     , setHeader
  19     , setHeader'
  20     , deleteHeader
  21
  22     , putBuilder
  23
  24     , driftTo
  25     )
  26     where
  27 import Blaze.ByteString.Builder (Builder)
  28 import Control.Applicative
  29 import Control.Concurrent
  30 import Control.Concurrent.STM
  31 import Control.Exception
  32 import Control.Monad.IO.Class
  33 import Control.Monad.Reader
  34 import Data.Ascii (Ascii, CIAscii)
  35 import qualified Data.Ascii as A
  36 import Data.List
  37 import Data.Maybe
  38 import Data.Monoid.Unicode
  39 import qualified Data.Text as T
  40 import Network.HTTP.Lucu.Abortion
  41 import Network.HTTP.Lucu.Config
  42 import Network.HTTP.Lucu.DefaultPage
  43 import qualified Network.HTTP.Lucu.Headers as H
  44 import Network.HTTP.Lucu.Interaction
  45 import Network.HTTP.Lucu.Postprocess
  46 import Network.HTTP.Lucu.Request
  47 import Network.HTTP.Lucu.Response
  48 import Network.HTTP.Lucu.Utils
  49 import Prelude hiding (catch)
  50 import Prelude.Unicode
  51 import System.IO
  52
  53 -- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
  54 -- any 'IO' actions.
  55 newtype Resource a
  56     = Resource {
  57         unResource ∷ ReaderT Interaction IO a
  58       }
  59     deriving (Applicative, Functor, Monad, MonadIO)
  60
  61 runResource ∷ Resource a → Interaction → IO a
  62 runResource = runReaderT ∘ unResource
  63
  64 -- | 'ResourceDef' is basically a set of 'Resource' monads for each
  65 -- HTTP methods.
  66 data ResourceDef = ResourceDef {
  67     -- |Whether to run a 'Resource' on a native thread (spawned by
  68     -- 'forkOS') or to run it on a user thread (spanwed by
  69     -- 'forkIO'). Generally you don't need to set this field to
  70     -- 'True'.
  71       resUsesNativeThread ∷ !Bool
  72     -- | Whether to be greedy or not.
  73     --
  74     -- Say a client is trying to access \/aaa\/bbb\/ccc. If there is a
  75     -- greedy resource at \/aaa\/bbb, it is always chosen even if
  76     -- there is another resource at \/aaa\/bbb\/ccc. If the resource
  77     -- at \/aaa\/bbb is not greedy, it is just ignored. Greedy
  78     -- resources are like CGI scripts.
  79     , resIsGreedy         ∷ !Bool
  80     -- | A 'Resource' to be run when a GET request comes for the
  81     -- resource path. If 'resGet' is Nothing, the system responds
  82     -- \"405 Method Not Allowed\" for GET requests.
  83     --
  84     -- It also runs for HEAD request if the 'resHead' is Nothing. In
  85     -- this case 'output' and such like don't actually write a
  86     -- response body.
  87     , resGet              ∷ !(Maybe (Resource ()))
  88     -- | A 'Resource' to be run when a HEAD request comes for the
  89     -- resource path. If 'resHead' is Nothing, the system runs
  90     -- 'resGet' instead. If 'resGet' is also Nothing, the system
  91     -- responds \"405 Method Not Allowed\" for HEAD requests.
  92     , resHead             ∷ !(Maybe (Resource ()))
  93     -- | A 'Resource' to be run when a POST request comes for the
  94     -- resource path. If 'resPost' is Nothing, the system responds
  95     -- \"405 Method Not Allowed\" for POST requests.
  96     , resPost             ∷ !(Maybe (Resource ()))
  97     -- | A 'Resource' to be run when a PUT request comes for the
  98     -- resource path. If 'resPut' is Nothing, the system responds
  99     -- \"405 Method Not Allowed\" for PUT requests.
 100     , resPut              ∷ !(Maybe (Resource ()))
 101     -- | A 'Resource' to be run when a DELETE request comes for the
 102     -- resource path. If 'resDelete' is Nothing, the system responds
 103     -- \"405 Method Not Allowed\" for DELETE requests.
 104     , resDelete           ∷ !(Maybe (Resource ()))
 105     }
 106
 107 -- |'emptyResource' is a resource definition with no actual
 108 -- handlers. You can construct a 'ResourceDef' by selectively
 109 -- overriding 'emptyResource'. It is defined as follows:
 110 --
 111 -- @
 112 --   emptyResource = ResourceDef {
 113 --                     resUsesNativeThread = False
 114 --                   , resIsGreedy         = False
 115 --                   , resGet              = Nothing
 116 --                   , resHead             = Nothing
 117 --                   , resPost             = Nothing
 118 --                   , resPut              = Nothing
 119 --                   , resDelete           = Nothing
 120 --                   }
 121 -- @
 122 emptyResource ∷ ResourceDef
 123 emptyResource = ResourceDef {
 124                   resUsesNativeThread = False
 125                 , resIsGreedy         = False
 126                 , resGet              = Nothing
 127                 , resHead             = Nothing
 128                 , resPost             = Nothing
 129                 , resPut              = Nothing
 130                 , resDelete           = Nothing
 131                 }
 132
 133 spawnResource ∷ ResourceDef → Interaction → IO ThreadId
 134 spawnResource (ResourceDef {..}) itr@(Interaction {..})
 135     = fork $ run `catch` processException
 136     where
 137       fork ∷ IO () → IO ThreadId
 138       fork | resUsesNativeThread = forkOS
 139            | otherwise           = forkIO
 140
 141       run ∷ IO ()
 142       run = flip runResource itr $
 143             do req ← getRequest
 144                fromMaybe notAllowed $ rsrc req
 145                driftTo Done
 146
 147       rsrc ∷ Request → Maybe (Resource ())
 148       rsrc req
 149           = case reqMethod req of
 150               GET    → resGet
 151               HEAD   → case resHead of
 152                           Just r  → Just r
 153                           Nothing → resGet
 154               POST   → resPost
 155               PUT    → resPut
 156               DELETE → resDelete
 157               _      → error $ "Unknown request method: " ⧺ show (reqMethod req)
 158
 159       notAllowed ∷ Resource ()
 160       notAllowed
 161           = setStatus MethodNotAllowed
 162             *>
 163             (setHeader "Allow" $ A.fromAsciiBuilder
 164                                $ joinWith ", "
 165                                $ map A.toAsciiBuilder allowedMethods)
 166
 167       allowedMethods ∷ [Ascii]
 168       allowedMethods = nub $ concat [ methods resGet    ["GET"]
 169                                     , methods resHead   ["GET", "HEAD"]
 170                                     , methods resPost   ["POST"]
 171                                     , methods resPut    ["PUT"]
 172                                     , methods resDelete ["DELETE"]
 173                                     ]
 174
 175       methods ∷ Maybe a → [Ascii] → [Ascii]
 176       methods m xs
 177           | isJust m  = xs
 178           | otherwise = []
 179
 180       toAbortion ∷ SomeException → Abortion
 181       toAbortion e
 182           = case fromException e of
 183               Just abortion → abortion
 184               Nothing       → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
 185
 186       processException ∷ SomeException → IO ()
 187       processException exc
 188           = do let abo = toAbortion exc
 189                -- まだ DecidingHeader 以前の状態だったら、この途中終了
 190                -- を應答に反映させる餘地がある。さうでなければ stderr
 191                -- にでも吐くしか無い。
 192                state ← atomically $ readTVar itrState
 193                res   ← atomically $ readTVar itrResponse
 194                if state ≤ DecidingHeader then
 195                    flip runResource itr $
 196                        do setStatus $ aboStatus abo
 197                           setHeader "Content-Type" defaultPageContentType
 198                           deleteHeader "Content-Encoding"
 199                           mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
 200                           putBuilder $ abortPage itrConfig itrRequest res abo
 201                else
 202                    when (cnfDumpTooLateAbortionToStderr itrConfig)
 203                        $ dumpAbortion abo
 204                runResource (driftTo Done) itr
 205
 206 dumpAbortion ∷ Abortion → IO ()
 207 dumpAbortion abo
 208     = hPutStr stderr
 209       $ concat [ "Lucu: an exception occured after "
 210                , "sending response header to the client:\n"
 211                , "  ", show abo, "\n"
 212                ]
 213
 214 getInteraction ∷ Resource Interaction
 215 getInteraction = Resource ask
 216
 217 -- |Get the 'Request' value which represents the request header. In
 218 -- general you don't have to use this action.
 219 getRequest ∷ Resource Request
 220 getRequest = (fromJust ∘ itrRequest) <$> getInteraction
 221
 222 -- | Set the response status code. If you don't call this function,
 223 -- the status code will be defaulted to \"200 OK\".
 224 setStatus ∷ StatusCode → Resource ()
 225 setStatus sc
 226     = do driftTo DecidingHeader
 227          itr ← getInteraction
 228          liftIO
 229              $ atomically
 230              $ setResponseStatus itr sc
 231
 232 -- | @'setHeader' name value@ sets the value of the response header
 233 -- @name@ to @value@. Note that this function is not intended to be
 234 -- used so frequently: there should be specialised functions like
 235 -- 'setContentType' for every common headers.
 236 --
 237 -- Some important headers (especially \"Content-Length\" and
 238 -- \"Transfer-Encoding\") may be silently dropped or overwritten by
 239 -- the system not to corrupt the interaction with client at the
 240 -- viewpoint of HTTP protocol layer. For instance, if we are keeping
 241 -- the connection alive, without this manipulation it will be a
 242 -- catastrophe when we send a header \"Content-Length: 10\" and
 243 -- actually send a body of 20 bytes long to the remote peer. In this
 244 -- case the client shall only accept the first 10 bytes of response
 245 -- body and thinks that the residual 10 bytes is a part of the header
 246 -- of the next response.
 247 setHeader ∷ CIAscii → Ascii → Resource ()
 248 setHeader name value
 249     = driftTo DecidingHeader *> setHeader' name value
 250
 251 setHeader' ∷ CIAscii → Ascii → Resource ()
 252 setHeader' name value
 253     = do itr ← getInteraction
 254          liftIO $ atomically
 255                 $ do res ← readTVar $ itrResponse itr
 256                      let res' = H.setHeader name value res
 257                      writeTVar (itrResponse itr) res'
 258                      when (name ≡ "Content-Type")
 259                          $ writeTVar (itrResponseHasCType itr) True
 260
 261 -- | @'deleteHeader' name@ deletes a response header @name@ if
 262 -- any. This function is not intended to be used so frequently.
 263 deleteHeader ∷ CIAscii → Resource ()
 264 deleteHeader name
 265     = driftTo DecidingHeader *> deleteHeader' name
 266
 267 deleteHeader' ∷ CIAscii → Resource ()
 268 deleteHeader' name
 269     = do itr ← getInteraction
 270          liftIO $ atomically
 271                 $ do res ← readTVar $ itrResponse itr
 272                      let res' = H.deleteHeader name res
 273                      writeTVar (itrResponse itr) res'
 274                      when (name ≡ "Content-Type")
 275                          $ writeTVar (itrResponseHasCType itr) False
 276
 277 -- | Run a 'Builder' to construct a chunk, and write it to the
 278 -- response body. It is safe to apply this function to a 'Builder'
 279 -- producing an infinitely long stream of octets.
 280 --
 281 -- Note that you must first set the response header \"Content-Type\"
 282 -- before applying this function. See: 'setContentType'
 283 putBuilder ∷ Builder → Resource ()
 284 putBuilder b
 285     = do itr ← getInteraction
 286          liftIO $ atomically
 287                 $ do driftTo' itr DecidingBody
 288                      hasCType ← readTVar $ itrResponseHasCType itr
 289                      unless hasCType
 290                          $ abortSTM InternalServerError []
 291                          $ Just "putBuilder: Content-Type has not been set."
 292                      putTMVar (itrBodyToSend itr) b
 293
 294 driftTo ∷ InteractionState → Resource ()
 295 driftTo newState
 296     = do itr ← getInteraction
 297          liftIO $ atomically $ driftTo' itr newState
 298
 299 driftTo' ∷ Interaction → InteractionState → STM ()
 300 driftTo' itr@(Interaction {..}) newState
 301     = do oldState ← readTVar itrState
 302          if newState < oldState then
 303              throwStateError oldState newState
 304          else
 305              do let a = [oldState .. newState]
 306                     b = tail a
 307                     c = zip a b
 308                 mapM_ (uncurry drift) c
 309                 writeTVar itrState newState
 310     where
 311       throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
 312       throwStateError Done DecidingBody
 313           = fail "It makes no sense to output something after finishing outputs."
 314       throwStateError old new
 315           = fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
 316
 317       drift ∷ InteractionState → InteractionState → STM ()
 318       drift GettingBody _
 319           = putTMVar itrGetBodyRequest WasteAll
 320       drift DecidingHeader _
 321           = postprocess itr
 322       drift _ _
 323           = return ()