{-# LANGUAGE GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings , RecordWildCards , UnicodeSyntax #-} -- |This is the Resource Monad; monadic actions to define a behavior -- of resource. The 'Resource' Monad is a kind of 'IO' Monad thus it -- implements 'MonadIO' class, and it is a state machine as well. -- -- Request Processing Flow: -- -- 1. A client issues an HTTP request. -- -- 2. If the URI of it matches to any resource, the corresponding -- 'Resource' Monad starts running on a newly spawned thread. -- -- 3. The 'Resource' Monad looks at request headers, find (or not -- find) an entity, receive the request body (if any), send -- response headers, and then send a response body. This process -- will be discussed later. -- -- 4. The 'Resource' Monad and its thread stops running. The client -- may or may not be sending us the next request at this point. -- -- 'Resource' Monad takes the following states. The initial state is -- /Examining Request/ and the final state is /Done/. -- -- [/Examining Request/] In this state, a 'Resource' looks at the -- request header fields and thinks about a corresponding entity for -- it. If there is a suitable entity, the 'Resource' tells the -- system an entity tag and its last modification time -- ('foundEntity'). If it found no entity, it tells the system so -- ('foundNoEntity'). In case it is impossible to decide the -- existence of entity, which is a typical case for POST requests, -- 'Resource' does nothing in this state. -- -- [/Receiving Body/] A 'Resource' asks the system to receive a -- request body from the client. Before actually reading from the -- socket, the system sends \"100 Continue\" to the client if need -- be. When a 'Resource' transits to the next state without -- receiving all or part of a request body, the system automatically -- receives and discards it. -- -- [/Deciding Header/] A 'Resource' makes a decision of status code -- and response header fields. When it transits to the next state, -- the system validates and completes the response header fields and -- then sends them to the client. -- -- [/Sending Body/] In this state, a 'Resource' asks the system to -- write some response body to the socket. When it transits to the -- next state without writing any response body, the system -- automatically completes it depending on the status code. (To be -- exact, such completion only occurs when the 'Resource' transits -- to this state without even declaring the \"Content-Type\" header -- field. See 'setContentType'.) -- -- [/Done/] Everything is over. A 'Resource' can do nothing for the -- HTTP interaction anymore. -- -- Note that the state transition is one-way: for instance, it is an -- error to try to read a request body after writing some -- response. This limitation is for efficiency. We don't want to read -- the entire request before starting 'Resource', nor we don't want to -- postpone writing the entire response till the end of 'Resource' -- computation. module Network.HTTP.Lucu.Resource ( -- * Types Resource , ResourceDef(..) , emptyResource , FormData(..) -- * Getting request header -- |These functions can be called regardless of the current state, -- and they don't change the state of 'Resource'. , getConfig , getRemoteAddr , getRemoteAddr' , getRemoteHost , getRemoteCertificate , getRequest , getMethod , getRequestURI , getRequestVersion , getResourcePath , getPathInfo , getQueryForm , getHeader , getAccept , getAcceptEncoding , isEncodingAcceptable , getContentType , getAuthorization -- * Finding an entity -- |These functions can be called only in the /Examining Request/ -- state. They make the 'Resource' transit to the /Receiving Body/ -- state. , foundEntity , foundETag , foundTimeStamp , foundNoEntity -- * Receiving a request body -- |These functions make the 'Resource' transit to the /Receiving -- Body/ state. , getChunk , getChunks , getForm -- * Declaring response status and header fields -- |These functions can be called at any time before transiting to -- the /Sending Body/ state, but they themselves never causes any -- state transitions. , setStatus , redirect , setContentType , setContentEncoding , setWWWAuthenticate -- ** Less frequently used functions , setLocation , setHeader , deleteHeader -- * Sending a response body -- |These functions make the 'Resource' transit to the /Sending -- Body/ state. , putChunk , putChunks , putBuilder ) where import qualified Blaze.ByteString.Builder.ByteString as BB import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Unicode import Data.Ascii (Ascii, CIAscii) import qualified Data.Ascii as A import qualified Data.Attoparsec.Char8 as P import qualified Data.Attoparsec.Lazy as LP import Data.ByteString (ByteString) import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Lazy.Internal as Lazy import Data.Foldable (toList) import Data.List import qualified Data.Map as M import Data.Maybe import Data.Monoid.Unicode import Data.Sequence (Seq) import Data.Sequence.Unicode hiding ((∅)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time import qualified Data.Time.HTTP as HTTP import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Authentication import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ContentCoding import Network.HTTP.Lucu.ETag import qualified Network.HTTP.Lucu.Headers as H import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.MultipartForm import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Resource.Internal import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.MIMEType import Network.HTTP.Lucu.Utils import Network.Socket hiding (accept) import Network.URI hiding (path) import Prelude.Unicode -- |Get the string representation of the address of remote host. If -- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'. getRemoteAddr' ∷ Resource HostName getRemoteAddr' = do sa ← getRemoteAddr (fromJust ∘ fst) <$> (liftIO $ getNameInfo [NI_NUMERICHOST] True False sa) -- |Resolve an address to the remote host. getRemoteHost ∷ Resource (Maybe HostName) getRemoteHost = do sa ← getRemoteAddr fst <$> (liftIO $ getNameInfo [] True False sa) -- |Get the 'Method' value of the request. getMethod ∷ Resource Method getMethod = reqMethod <$> getRequest -- |Get the URI of the request. getRequestURI ∷ Resource URI getRequestURI = reqURI <$> getRequest -- |Get the HTTP version of the request. getRequestVersion ∷ Resource HttpVersion getRequestVersion = reqVersion <$> getRequest -- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns -- @[]@ if the corresponding -- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See -- 'getResourcePath'. -- -- Note that the returned path components are URI-decoded. getPathInfo ∷ Resource [Strict.ByteString] getPathInfo = do rsrcPath ← getResourcePath reqPath ← splitPathInfo <$> getRequestURI return $ drop (length rsrcPath) reqPath -- |Assume the query part of request URI as -- application\/x-www-form-urlencoded, and parse it into pairs of -- @(name, formData)@. This function doesn't read the request -- body. Field names are decoded in UTF-8 for an hardly avoidable -- reason. See 'getForm'. getQueryForm ∷ Resource [(Text, FormData)] getQueryForm = parse' <$> getRequestURI where parse' = map toPairWithFormData ∘ parseWWWFormURLEncoded ∘ fromJust ∘ A.fromChars ∘ drop 1 ∘ uriQuery toPairWithFormData ∷ (ByteString, ByteString) → (Text, FormData) toPairWithFormData (name, value) = let fd = FormData { fdFileName = Nothing , fdContent = Lazy.fromChunks [value] } in (T.decodeUtf8 name, fd) -- |@'getHeader' name@ returns the value of the request header field -- @name@. Comparison of header name is case-insensitive. Note that -- this function is not intended to be used so frequently: there -- should be actions like 'getContentType' for every common headers. getHeader ∷ CIAscii → Resource (Maybe Ascii) getHeader name = H.getHeader name <$> getRequest -- |Return the list of 'MIMEType' enumerated on the value of request -- header \"Accept\", or @[]@ if absent. getAccept ∷ Resource [MIMEType] getAccept = do acceptM ← getHeader "Accept" case acceptM of Nothing → return [] Just accept → case P.parseOnly p (A.toByteString accept) of Right xs → return xs Left _ → abort BadRequest [] (Just $ "Unparsable Accept: " ⊕ A.toText accept) where p = do xs ← mimeTypeListP P.endOfInput return xs -- |Return the list of @(contentCoding, qvalue)@ enumerated on the -- value of request header \"Accept-Encoding\". The list is sorted in -- descending order by qvalue. getAcceptEncoding ∷ Resource [(CIAscii, Maybe Double)] getAcceptEncoding = do accEncM ← getHeader "Accept-Encoding" case accEncM of Nothing -- HTTP/1.0 には Accept-Encoding が無い場合の規定が無い -- ので安全の爲 identity が指定された事にする。HTTP/1.1 -- の場合は何でも受け入れて良い事になってゐるので "*" が -- 指定された事にする。 → do ver ← getRequestVersion case ver of HttpVersion 1 0 → return [("identity", Nothing)] HttpVersion 1 1 → return [("*" , Nothing)] _ → abort InternalServerError [] (Just "getAcceptEncoding: unknown HTTP version") Just ae → if ae ≡ "" then -- identity のみが許される。 return [("identity", Nothing)] else case P.parseOnly p (A.toByteString ae) of Right xs → return $ map toTuple $ reverse $ sort xs Left _ → abort BadRequest [] (Just $ "Unparsable Accept-Encoding: " ⊕ A.toText ae) where p = do xs ← acceptEncodingListP P.endOfInput return xs toTuple (AcceptEncoding {..}) = (aeEncoding, aeQValue) -- |Return 'True' iff a given content-coding is acceptable. isEncodingAcceptable ∷ CIAscii → Resource Bool isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding where doesMatch ∷ (CIAscii, Maybe Double) → Bool doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0 -- |Return the value of request header \"Content-Type\" as 'MIMEType'. getContentType ∷ Resource (Maybe MIMEType) getContentType = do cTypeM ← getHeader "Content-Type" case cTypeM of Nothing → return Nothing Just cType → case P.parseOnly p (A.toByteString cType) of Right t → return $ Just t Left _ → abort BadRequest [] (Just $ "Unparsable Content-Type: " ⊕ A.toText cType) where p = do t ← mimeTypeP P.endOfInput return t -- |Return the value of request header \"Authorization\" as -- 'AuthCredential'. getAuthorization ∷ Resource (Maybe AuthCredential) getAuthorization = do authM ← getHeader "Authorization" case authM of Nothing → return Nothing Just auth → case P.parseOnly p (A.toByteString auth) of Right ac → return $ Just ac Left _ → return Nothing where p = do ac ← authCredentialP P.endOfInput return ac -- |Tell the system that the 'Resource' found an entity for the -- request URI. If this is a GET or HEAD request, a found entity means -- a datum to be replied. If this is a PUT or DELETE request, it means -- a datum which was stored for the URI until now. For POST requests -- it raises an error. -- -- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test -- whenever possible, and if those tests fail, it immediately aborts -- with status \"412 Precondition Failed\" or \"304 Not Modified\" -- depending on the situation. -- -- If the request method is either GET or HEAD, 'foundEntity' -- automatically puts \"ETag\" and \"Last-Modified\" headers into the -- response. foundEntity ∷ ETag → UTCTime → Resource () foundEntity tag timeStamp = do driftTo ExaminingRequest method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) when (method ≡ POST) $ abort InternalServerError [] (Just "foundEntity: this is a POST request.") foundETag tag driftTo ReceivingBody -- |Tell the system that the 'Resource' found an entity for the -- request URI. The only difference from 'foundEntity' is that -- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into -- the response. -- -- Using this function is discouraged. You should use 'foundEntity' -- whenever possible. foundETag ∷ ETag → Resource () foundETag tag = do driftTo ExaminingRequest method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "ETag" $ A.fromAsciiBuilder $ printETag tag when (method ≡ POST) $ abort InternalServerError [] $ Just "Illegal computation of foundETag for POST request." -- If-Match があればそれを見る。 ifMatch ← getHeader "If-Match" case ifMatch of Nothing → return () Just value → if value ≡ "*" then return () else case P.parseOnly p (A.toByteString value) of Right tags -- tags の中に一致するものが無ければ -- PreconditionFailed で終了。 → when ((¬) (any (≡ tag) tags)) $ abort PreconditionFailed [] $ Just $ "The entity tag doesn't match: " ⊕ A.toText value Left _ → abort BadRequest [] $ Just $ "Unparsable If-Match: " ⊕ A.toText value let statusForNoneMatch = if method ≡ GET ∨ method ≡ HEAD then NotModified else PreconditionFailed -- If-None-Match があればそれを見る。 ifNoneMatch ← getHeader "If-None-Match" case ifNoneMatch of Nothing → return () Just value → if value ≡ "*" then abort statusForNoneMatch [] (Just "The entity tag matches: *") else case P.parseOnly p (A.toByteString value) of Right tags → when (any (≡ tag) tags) $ abort statusForNoneMatch [] $ Just $ "The entity tag matches: " ⊕ A.toText value Left _ → abort BadRequest [] $ Just $ "Unparsable If-None-Match: " ⊕ A.toText value driftTo ReceivingBody where p = do xs ← eTagListP P.endOfInput return xs -- |Tell the system that the 'Resource' found an entity for the -- request URI. The only difference from 'foundEntity' is that -- 'foundTimeStamp' performs \"If-Modified-Since\" test or -- \"If-Unmodified-Since\" test instead of \"If-Match\" test or -- \"If-None-Match\" test. Be aware that any tests based on a last -- modification time are unsafe because it is possible to mess up such -- tests by modifying the entity twice in a second. -- -- Using this function is discouraged. You should use 'foundEntity' -- whenever possible. foundTimeStamp ∷ UTCTime → Resource () foundTimeStamp timeStamp = do driftTo ExaminingRequest method ← getMethod when (method ≡ GET ∨ method ≡ HEAD) $ setHeader "Last-Modified" (HTTP.toAscii timeStamp) when (method ≡ POST) $ abort InternalServerError [] (Just "Illegal computation of foundTimeStamp for POST request.") let statusForIfModSince = if method ≡ GET ∨ method ≡ HEAD then NotModified else PreconditionFailed -- If-Modified-Since があればそれを見る。 ifModSince ← getHeader "If-Modified-Since" case ifModSince of Just str → case HTTP.fromAscii str of Right lastTime → when (timeStamp ≤ lastTime) $ abort statusForIfModSince [] (Just $ "The entity has not been modified since " ⊕ A.toText str) Left _ → return () -- 不正な時刻は無視 Nothing → return () -- If-Unmodified-Since があればそれを見る。 ifUnmodSince ← getHeader "If-Unmodified-Since" case ifUnmodSince of Just str → case HTTP.fromAscii str of Right lastTime → when (timeStamp > lastTime) $ abort PreconditionFailed [] (Just $ "The entity has not been modified since " ⊕ A.toText str) Left _ → return () -- 不正な時刻は無視 Nothing → return () driftTo ReceivingBody -- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found -- no entity for the request URI. @mStr@ is an optional error message -- to be replied to the client. -- -- If the request method is PUT, 'foundNoEntity' performs \"If-Match\" -- test and when that fails it aborts with status \"412 Precondition -- Failed\". If the request method is GET, HEAD, POST or DELETE, -- 'foundNoEntity' always aborts with status \"404 Not Found\". foundNoEntity ∷ Maybe Text → Resource () foundNoEntity msgM = do driftTo ExaminingRequest method ← getMethod when (method ≢ PUT) $ abort NotFound [] msgM -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな -- If-Match: 條件も滿たさない。 ifMatch ← getHeader "If-Match" when (ifMatch ≢ Nothing) $ abort PreconditionFailed [] msgM driftTo ReceivingBody -- |@'getChunks' limit@ attemts to read the entire request body up to -- @limit@ bytes, and then make the 'Resource' transit to the -- /Deciding Header/ state. When the actual size of the body is larger -- than @limit@ bytes, 'getChunks' immediately aborts with status -- \"413 Request Entity Too Large\". When the request has no body, it -- returns an empty string. -- -- When the @limit@ is 'Nothing', 'getChunks' uses the default -- limitation value ('cnfMaxEntityLength') instead. -- -- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy: -- reading from the socket just happens at the computation of -- 'getChunks', not at the evaluation of the 'Lazy.ByteString'. getChunks ∷ Maybe Int → Resource Lazy.ByteString getChunks (Just n) | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n) | n ≡ 0 = return (∅) | otherwise = getChunks' n getChunks Nothing = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength getChunks' ∷ Int → Resource Lazy.ByteString getChunks' limit = go limit (∅) where go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString go 0 _ = abort RequestEntityTooLarge [] (Just $ "Request body must be smaller than " ⊕ T.pack (show limit) ⊕ " bytes.") go n xs = do let n' = min n Lazy.defaultChunkSize chunk ← getChunk n' if Strict.null chunk then -- Got EOF return $ Lazy.fromChunks $ toList xs else do let n'' = n' - Strict.length chunk xs' = xs ⊳ chunk go n'' xs' -- |@'getForm' limit@ attempts to read the request body with -- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or -- @multipart\/form-data@. If the request header \"Content-Type\" is -- neither of them, 'getForm' aborts with status \"415 Unsupported -- Media Type\". If the request has no \"Content-Type\", it aborts -- with \"400 Bad Request\". -- -- Field names in @multipart\/form-data@ will be precisely decoded in -- accordance with RFC 2231. On the other hand, -- @application\/x-www-form-urlencoded@ says nothing about character -- encodings for field names, so they'll always be decoded in -- UTF-8. (This could be a bad design, but I can't think of any better -- idea.) getForm ∷ Maybe Int → Resource [(Text, FormData)] getForm limit = do cTypeM ← getContentType case cTypeM of Nothing → abort BadRequest [] (Just "Missing Content-Type") Just (MIMEType "application" "x-www-form-urlencoded" _) → readWWWFormURLEncoded Just (MIMEType "multipart" "form-data" params) → readMultipartFormData params Just cType → abort UnsupportedMediaType [] $ Just $ A.toText $ A.fromAsciiBuilder $ A.toAsciiBuilder "Unsupported media type: " ⊕ printMIMEType cType where readWWWFormURLEncoded = (map toPairWithFormData ∘ parseWWWFormURLEncoded) <$> (bsToAscii =≪ getChunks limit) bsToAscii bs = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of Just a → return a Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded") readMultipartFormData params = do case M.lookup "boundary" params of Nothing → abort BadRequest [] (Just "Missing boundary of multipart/form-data") Just boundary → do src ← getChunks limit b ← case A.fromText boundary of Just b → return b Nothing → abort BadRequest [] (Just $ "Malformed boundary: " ⊕ boundary) case LP.parse (p b) src of LP.Done _ formList → return formList _ → abort BadRequest [] (Just "Unparsable multipart/form-data") where p b = do xs ← multipartFormP b P.endOfInput return xs -- |@'redirect' code uri@ declares the response status as @code@ and -- \"Location\" header field as @uri@. The @code@ must satisfy -- 'isRedirection' or it raises an error. redirect ∷ StatusCode → URI → Resource () redirect code uri = do when (code ≡ NotModified ∨ not (isRedirection code)) $ abort InternalServerError [] $ Just $ A.toText $ A.fromAsciiBuilder $ A.toAsciiBuilder "Attempted to redirect with status " ⊕ printStatusCode code setStatus code setLocation uri -- |@'setContentType' mType@ declares the response header -- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is -- mandatory for sending a response body. setContentType ∷ MIMEType → Resource () setContentType = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType -- |@'setLocation' uri@ declares the response header \"Location\" as -- @uri@. You usually don't need to call this function directly. setLocation ∷ URI → Resource () setLocation uri = case A.fromChars uriStr of Just a → setHeader "Location" a Nothing → abort InternalServerError [] (Just $ "Malformed URI: " ⊕ T.pack uriStr) where uriStr = uriToString id uri "" -- |@'setContentEncoding' codings@ declares the response header -- \"Content-Encoding\" as @codings@. setContentEncoding ∷ [CIAscii] → Resource () setContentEncoding codings = do ver ← getRequestVersion tr ← case ver of HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding) HttpVersion 1 1 → return toAB _ → abort InternalServerError [] (Just "setContentEncoding: Unknown HTTP version") setHeader "Content-Encoding" (A.fromAsciiBuilder $ joinWith ", " $ map tr codings) where toAB = A.toAsciiBuilder ∘ A.fromCIAscii -- |@'setWWWAuthenticate' challenge@ declares the response header -- \"WWW-Authenticate\" as @challenge@. setWWWAuthenticate ∷ AuthChallenge → Resource () setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge -- |Write a chunk in 'Strict.ByteString' to the response body. You -- must first declare the response header \"Content-Type\" before -- applying this function. See 'setContentType'. putChunk ∷ Strict.ByteString → Resource () putChunk = putBuilder ∘ BB.fromByteString -- |Write a chunk in 'Lazy.ByteString' to the response body. It is -- safe to apply this function to an infinitely long -- 'Lazy.ByteString'. -- -- Note that you must first declare the response header -- \"Content-Type\" before applying this function. See -- 'setContentType'. putChunks ∷ Lazy.ByteString → Resource () putChunks = putBuilder ∘ BB.fromLazyByteString