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.Postprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
-import Network.HTTP.Lucu.Utils
import Network.Socket
import OpenSSL.X509
import Prelude hiding (catch)
-- 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
_ → 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"]
-- > 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 = niResourcePath <$> getInteraction
-- |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 ni ← getInteraction
liftIO $ atomically
-- 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 ni ← getInteraction
- liftIO $ atomically $ go ni
+setHeader name value = liftIO ∘ atomically ∘ go =≪ getInteraction
where
go ∷ NormalInteraction → STM ()
go (NI {..})
-- |@'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 ni ← getInteraction
- liftIO $ atomically $ go ni
+deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
where
go ∷ NormalInteraction → STM ()
go (NI {..})
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 ni ← getInteraction
- liftIO $ atomically $ go ni
+putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
where
go ∷ NormalInteraction → STM ()
go ni@(NI {..})
putTMVar niBodyToSend b
driftTo ∷ InteractionState → Resource ()
-driftTo newState
- = do ni ← getInteraction
- liftIO $ atomically $ driftTo' ni newState
+driftTo = (getInteraction ≫=) ∘ ((liftIO ∘ atomically) ∘) ∘ flip driftTo'
driftTo' ∷ NormalInteraction → InteractionState → STM ()
driftTo' ni@(NI {..}) newState