{-# LANGUAGE
- DoAndIfThenElse
+ CPP
+ , DoAndIfThenElse
, GeneralizedNewtypeDeriving
, OverloadedStrings
, RecordWildCards
, getConfig
, getRemoteAddr
+#if defined(HAVE_SSL)
, getRemoteCertificate
+#endif
, getRequest
, getResourcePath
import Control.Exception
import Control.Monad.IO.Class
import Control.Monad.Reader
+import Control.Monad.Unicode
import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import qualified Data.ByteString as Strict
import Data.List
import Data.Maybe
+import Data.Monoid
import Data.Monoid.Unicode
import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
+import Network.HTTP.Lucu.Abortion.Internal
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.DefaultPage
import qualified Network.HTTP.Lucu.Headers as H
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Utils
import Network.Socket
+#if defined(HAVE_SSL)
import OpenSSL.X509
+#endif
import Prelude hiding (catch)
import Prelude.Unicode
import System.IO
-- any 'IO' actions.
newtype Resource a
= Resource {
- unResource ∷ ReaderT Interaction IO a
+ unResource ∷ ReaderT NormalInteraction IO a
}
deriving (Applicative, Functor, Monad, MonadIO)
-runResource ∷ Resource a → Interaction → IO a
+runResource ∷ Resource a → NormalInteraction → IO a
runResource = runReaderT ∘ unResource
-- |'ResourceDef' is basically a set of 'Resource' monads for each
-- resource path. If 'resGet' is Nothing, the system responds
-- \"405 Method Not Allowed\" for GET requests.
--
- -- It also runs for HEAD request if the 'resHead' is Nothing. In
- -- this case 'output' and such like don't actually write a
- -- response body.
+ -- It also runs for HEAD request if the 'resHead' is 'Nothing'. In
+ -- that case 'putChunk' and such don't actually write a response
+ -- body.
, resGet ∷ !(Maybe (Resource ()))
-- |A 'Resource' to be run when a HEAD request comes for the
-- resource path. If 'resHead' is Nothing, the system runs
, resDelete = Nothing
}
-spawnResource ∷ ResourceDef → Interaction → IO ThreadId
-spawnResource (ResourceDef {..}) itr@(Interaction {..})
+spawnResource ∷ ResourceDef → NormalInteraction → IO ThreadId
+spawnResource (ResourceDef {..}) ni@(NI {..})
= fork $ run `catch` processException
where
fork ∷ IO () → IO ThreadId
| otherwise = forkIO
run ∷ IO ()
- run = flip runResource itr $
+ run = flip runResource ni $
do req ← getRequest
fromMaybe notAllowed $ rsrc req
driftTo Done
_ → error $ "Unknown request method: " ⧺ show (reqMethod req)
notAllowed ∷ Resource ()
- notAllowed
- = setStatus MethodNotAllowed
- *>
- (setHeader "Allow" $ A.fromAsciiBuilder
- $ joinWith ", "
- $ map A.toAsciiBuilder allowedMethods)
+ notAllowed = do setStatus MethodNotAllowed
+ setHeader "Allow"
+ $ A.fromAsciiBuilder
+ $ mconcat
+ $ intersperse (A.toAsciiBuilder ", ")
+ $ map A.toAsciiBuilder allowedMethods
allowedMethods ∷ [Ascii]
allowedMethods = nub $ concat [ methods resGet ["GET"]
toAbortion e
= case fromException e of
Just abortion → abortion
- Nothing → Abortion InternalServerError (∅) (Just $ T.pack $ show e)
+ Nothing → mkAbortion' InternalServerError $ T.pack $ show e
processException ∷ SomeException → IO ()
processException exc
= do let abo = toAbortion exc
- state ← atomically $ readTVar itrState
- res ← atomically $ readTVar itrResponse
+ state ← atomically $ readTVar niState
+ res ← atomically $ readTVar niResponse
if state ≤ DecidingHeader then
-- We still have a chance to reflect this abortion
-- in the response. Hooray!
- flip runResource itr $
+ flip runResource ni $
do setStatus $ aboStatus abo
+ mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
setHeader "Content-Type" defaultPageContentType
deleteHeader "Content-Encoding"
- mapM_ (uncurry setHeader) $ H.fromHeaders $ aboHeaders abo
- putBuilder $ abortPage itrConfig itrRequest res abo
+ putBuilder $ abortPage niConfig (Just niRequest) res abo
else
- when (cnfDumpTooLateAbortionToStderr itrConfig)
+ when (cnfDumpTooLateAbortionToStderr niConfig)
$ dumpAbortion abo
- runResource (driftTo Done) itr
+ runResource (driftTo Done) ni
dumpAbortion ∷ Abortion → IO ()
dumpAbortion abo
, " ", show abo, "\n"
]
-getInteraction ∷ Resource Interaction
+getInteraction ∷ Resource NormalInteraction
getInteraction = Resource ask
-- |Get the 'Config' value for this httpd.
getConfig ∷ Resource Config
-getConfig = itrConfig <$> getInteraction
+getConfig = niConfig <$> getInteraction
-- |Get the 'SockAddr' of the remote host.
getRemoteAddr ∷ Resource SockAddr
-getRemoteAddr = itrRemoteAddr <$> getInteraction
+getRemoteAddr = niRemoteAddr <$> getInteraction
+#if defined(HAVE_SSL)
-- | Return the X.509 certificate of the client, or 'Nothing' if:
--
-- * This request didn't came through an SSL stream.
-- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
-- 'OpenSSL.Session.VerifyPeer'.
getRemoteCertificate ∷ Resource (Maybe X509)
-getRemoteCertificate = itrRemoteCert <$> getInteraction
+getRemoteCertificate = niRemoteCert <$> getInteraction
+#endif
-- |Return the 'Request' value representing the request header. You
-- usually don't need to call this function directly.
getRequest ∷ Resource Request
-getRequest = (fromJust ∘ itrRequest) <$> getInteraction
+getRequest = niRequest <$> getInteraction
-- |Get the path of this 'Resource' (to be exact, 'ResourceDef') in
-- the 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
-- > main = let tree = mkResTree [ (["foo"], resFoo) ]
-- > in runHttpd defaultConfig tree []
-- >
--- > resFoo = ResourceDef {
+-- > resFoo = emptyResource {
-- > resIsGreedy = True
-- > , resGet = Just $ do requestURI <- getRequestURI
-- > resourcePath <- getResourcePath
-- > -- resourcePath == ["foo"]
-- > -- pathInfo == ["bar", "baz"]
-- > ...
--- > , ...
-- > }
getResourcePath ∷ Resource [Strict.ByteString]
-getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
+getResourcePath = niResourcePath <$> getInteraction
-- |@'getChunk' n@ attempts to read a chunk of request body up to @n@
-- bytes. You can incrementally read the request body by repeatedly
| n ≡ 0 = return (∅)
| otherwise = do req ← getRequest
if reqMustHaveBody req then
- do itr ← getInteraction
- askForInput itr
+ askForInput =≪ getInteraction
else
driftTo DecidingHeader *> return (∅)
where
- askForInput ∷ Interaction → Resource Strict.ByteString
- askForInput (Interaction {..})
+ askForInput ∷ NormalInteraction → Resource Strict.ByteString
+ askForInput (NI {..})
= do -- Ask the RequestReader to get a chunk.
liftIO $ atomically
- $ putTMVar itrReceiveBodyReq (ReceiveBody n)
+ $ putTMVar niReceiveBodyReq (ReceiveBody n)
-- Then wait for a reply.
chunk ← liftIO
$ atomically
- $ takeTMVar itrReceivedBody
+ $ takeTMVar niReceivedBody
-- Have we got an EOF?
when (Strict.null chunk)
$ driftTo DecidingHeader
-- |Declare the response status code. If you don't call this function,
-- the status code will be defaulted to \"200 OK\".
-setStatus ∷ StatusCode → Resource ()
+setStatus ∷ StatusCode sc ⇒ sc → Resource ()
setStatus sc
- = do itr ← getInteraction
+ = do ni ← getInteraction
liftIO $ atomically
- $ do state ← readTVar $ itrState itr
+ $ do state ← readTVar $ niState ni
when (state > DecidingHeader)
$ fail "Too late to declare the response status."
- setResponseStatus itr sc
+ res ← readTVar $ niResponse ni
+ writeTVar (niResponse ni) $ setStatusCode sc res
-- |@'setHeader' name value@ declares the value of the response header
-- @name@ as @value@. Note that this function is not intended to be
-- body and thinks that the residual 10 bytes is a part of the header
-- of the next response.
setHeader ∷ CIAscii → Ascii → Resource ()
-setHeader name value
- = do itr ← getInteraction
- liftIO $ atomically
- $ do state ← readTVar $ itrState itr
- when (state > DecidingHeader)
- $ fail "Too late to declare a response header field."
- res ← readTVar $ itrResponse itr
- let res' = H.setHeader name value res
- writeTVar (itrResponse itr) res'
- when (name ≡ "Content-Type")
- $ writeTVar (itrResponseHasCType itr) True
+setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
+ where
+ go ∷ NormalInteraction → STM ()
+ go (NI {..})
+ = do state ← readTVar niState
+ when (state > DecidingHeader) $
+ fail "Too late to declare a response header field."
+ res ← readTVar niResponse
+ writeTVar niResponse $ H.setHeader name value res
+ when (name ≡ "Content-Type") $
+ writeTVar niResponseHasCType True
-- |@'deleteHeader' name@ deletes a response header @name@ if
-- any. This function is not intended to be used so frequently.
deleteHeader ∷ CIAscii → Resource ()
-deleteHeader name
- = do itr ← getInteraction
- liftIO $ atomically
- $ do state ← readTVar $ itrState itr
- when (state > DecidingHeader)
- $ fail "Too late to delete a response header field."
- res ← readTVar $ itrResponse itr
- let res' = H.deleteHeader name res
- writeTVar (itrResponse itr) res'
- when (name ≡ "Content-Type")
- $ writeTVar (itrResponseHasCType itr) False
+deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
+ where
+ go ∷ NormalInteraction → STM ()
+ go (NI {..})
+ = do state ← readTVar niState
+ when (state > DecidingHeader) $
+ fail "Too late to delete a response header field."
+ res ← readTVar niResponse
+ writeTVar niResponse $ H.deleteHeader name res
+ when (name ≡ "Content-Type") $
+ writeTVar niResponseHasCType False
-- |Run a 'Builder' to construct a chunk, and write it to the response
--- body. It is safe to apply this function to a 'Builder' producing an
+-- body. It can be safely applied to a 'Builder' producing an
-- infinitely long stream of octets.
--
-- Note that you must first declare the response header
--- \"Content-Type\" before applying this function. See
--- 'setContentType'.
+-- \"Content-Type\" before applying this function. See:
+-- 'setContentType'
putBuilder ∷ Builder → Resource ()
-putBuilder b
- = do itr ← getInteraction
- liftIO $ atomically
- $ do driftTo' itr SendingBody
- hasCType ← readTVar $ itrResponseHasCType itr
- unless hasCType
- $ abortSTM InternalServerError []
- $ Just "putBuilder: Content-Type has not been set."
- putTMVar (itrBodyToSend itr) b
+putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
+ where
+ go ∷ NormalInteraction → STM ()
+ go ni@(NI {..})
+ = do driftTo' ni SendingBody
+ hasCType ← readTVar niResponseHasCType
+ unless hasCType
+ $ throwSTM
+ $ mkAbortion' InternalServerError
+ "putBuilder: Content-Type has not been set."
+ putTMVar niBodyToSend b
driftTo ∷ InteractionState → Resource ()
-driftTo newState
- = do itr ← getInteraction
- liftIO $ atomically $ driftTo' itr newState
+driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
-driftTo' ∷ Interaction → InteractionState → STM ()
-driftTo' itr@(Interaction {..}) newState
- = do oldState ← readTVar itrState
+driftTo' ∷ NormalInteraction → InteractionState → STM ()
+driftTo' ni@(NI {..}) newState
+ = do oldState ← readTVar niState
driftFrom oldState
where
driftFrom ∷ InteractionState → STM ()
b = tail a
c = zip a b
mapM_ (uncurry driftFromTo) c
- writeTVar itrState newState
+ writeTVar niState newState
throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
throwStateError Done SendingBody
driftFromTo ∷ InteractionState → InteractionState → STM ()
driftFromTo ReceivingBody _
- = putTMVar itrReceiveBodyReq WasteAll
+ = putTMVar niReceiveBodyReq WasteAll
driftFromTo DecidingHeader _
- = postprocess itr
+ = postprocess ni
driftFromTo _ _
= return ()
projects / Lucu.git / blobdiff