+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder as BB
+import qualified Blaze.ByteString.Builder.Internal as BB
+import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Unicode
+import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
+import Data.Attempt
+import qualified Data.Attoparsec.Char8 as P
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as Strict
+import qualified Data.ByteString.Lazy as Lazy
+import Data.Collections
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
+import Data.Convertible.Utils
+import Data.Default
+import Data.List (intersperse, sort)
+import Data.Maybe
+import Data.Monoid
+import Data.Monoid.Unicode
+import Data.Tagged
+import Data.Text (Text)
+import Data.Time
+import Data.Time.Format.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.Parser
+import Network.HTTP.Lucu.Request
+import Network.HTTP.Lucu.Resource.Internal
+import Network.HTTP.Lucu.Response
+import Network.HTTP.Lucu.Response.StatusCode
+import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.Utils
+import Network.Socket hiding (accept)
+import Network.URI hiding (path)
+import Prelude hiding (any, drop, lookup, reverse)
+import Prelude.Unicode
+
+-- |Get the string representation of the address of remote host. If
+-- you want a 'SockAddr' instead of 'HostName', use 'getRemoteAddr'.
+getRemoteAddr' ∷ Rsrc HostName
+getRemoteAddr' = liftIO ∘ toNM =≪ getRemoteAddr
+ where
+ toNM ∷ SockAddr → IO HostName
+ toNM = (fromJust ∘ fst <$>) ∘ getNameInfo [NI_NUMERICHOST] True False
+
+-- |Resolve an address to the remote host.
+getRemoteHost ∷ Rsrc (Maybe HostName)
+getRemoteHost = liftIO ∘ getHN =≪ getRemoteAddr
+ where
+ getHN ∷ SockAddr → IO (Maybe HostName)
+ getHN = (fst <$>) ∘ getNameInfo [] True False
+
+-- |Get the 'Method' value of the request.
+getMethod ∷ Rsrc Method
+getMethod = reqMethod <$> getRequest
+
+-- |Get the URI of the request.
+getRequestURI ∷ Rsrc URI
+getRequestURI = reqURI <$> getRequest
+
+-- |Get the HTTP version of the request.
+getRequestVersion ∷ Rsrc HttpVersion
+getRequestVersion = reqVersion <$> getRequest
+
+-- |This is an analogy of CGI PATH_INFO. 'getPathInfo' always returns
+-- @[]@ if the corresponding 'Resource' is not greedy. See
+-- 'getResourcePath'.
+--
+-- Note that the returned path components are URI-decoded.
+getPathInfo ∷ Rsrc [Strict.ByteString]
+getPathInfo = do rsrcPath ← getResourcePath
+ reqPath ← uriPathSegments <$> 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.
+getQueryForm ∷ Rsrc [(Strict.ByteString, FormData)]
+getQueryForm = parse' <$> getRequestURI
+ where
+ parse' = map toPairWithFormData ∘
+ parseWWWFormURLEncoded ∘
+ convertUnsafe ∘
+ drop 1 ∘
+ uriQuery
+
+toPairWithFormData ∷ (ByteString, ByteString) → (Strict.ByteString, FormData)
+toPairWithFormData (name, value)
+ = let fd = FormData {
+ fdFileName = Nothing
+ , fdMIMEType = [mimeType| text/plain |]
+ , fdContent = Lazy.fromChunks [value]
+ }
+ in (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 functions like 'getContentType' for every common headers.
+getHeader ∷ CIAscii → Rsrc (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 ∷ Rsrc [MIMEType]
+getAccept
+ = do acceptM ← getHeader "Accept"
+ case acceptM of
+ Nothing
+ → return []
+ Just accept
+ → case P.parseOnly (finishOff def) (cs accept) of
+ Right xs → return xs
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Accept: " ⊕ cs accept
+
+-- |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 ∷ Rsrc [(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 $ mkAbortion' InternalServerError
+ "getAcceptEncoding: unknown HTTP version"
+ Just ae
+ → if ae ≡ "" then
+ -- identity のみが許される。
+ return [("identity", Nothing)]
+ else
+ case P.parseOnly (finishOff def) (cs ae) of
+ Right xs → return $ map toTuple $ reverse $ sort xs
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Accept-Encoding: " ⊕ cs ae
+ where
+ toTuple (AcceptEncoding {..})
+ = (aeEncoding, aeQValue)
+
+-- |Return 'True' iff a given content-coding is acceptable by the
+-- client.
+isEncodingAcceptable ∷ CIAscii → Rsrc 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 ∷ Rsrc (Maybe MIMEType)
+getContentType
+ = do cTypeM ← getHeader "Content-Type"
+ case cTypeM of
+ Nothing
+ → return Nothing
+ Just cType
+ → case P.parseOnly (finishOff def) (cs cType) of
+ Right t → return $ Just t
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Content-Type: " ⊕ cs cType
+
+-- |Return the value of request header \"Authorization\" as
+-- 'AuthCredential'.
+getAuthorization ∷ Rsrc (Maybe AuthCredential)
+getAuthorization
+ = do authM ← getHeader "Authorization"
+ case authM of
+ Nothing
+ → return Nothing
+ Just auth
+ → case P.parseOnly (finishOff def) (cs auth) of
+ Right ac → return $ Just ac
+ Left _ → return Nothing
+
+-- |Tell the system that the 'Rsrc' 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 → Rsrc ()
+foundEntity tag timeStamp
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "Last-Modified"
+ $ formatUTCTime timeStamp
+ when (method ≡ POST)
+ $ abort
+ $ mkAbortion' InternalServerError
+ "foundEntity: this is a POST request."
+ foundETag tag
+
+ driftTo ReceivingBody
+
+-- |Tell the system that the 'Rsrc' 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 → Rsrc ()
+foundETag tag
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "ETag"
+ $ cs tag
+ when (method ≡ POST)
+ $ abort
+ $ mkAbortion' InternalServerError
+ "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 (finishOff def) (cs value) of
+ Right []
+ → abort $ mkAbortion' BadRequest
+ $ "Empty If-Match"
+ Right tags
+ -- tags の中に一致するものが無ければ
+ -- PreconditionFailed で終了。
+ → when ((¬) (any (≡ tag) tags))
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity tag doesn't match: " ⊕ cs value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-Match: " ⊕ cs value
+
+ let statusForNoneMatch
+ = if method ≡ GET ∨ method ≡ HEAD then
+ fromStatusCode NotModified
+ else
+ fromStatusCode PreconditionFailed
+
+ -- If-None-Match があればそれを見る。
+ ifNoneMatch ← getHeader "If-None-Match"
+ case ifNoneMatch of
+ Nothing
+ → return ()
+ Just value
+ → if value ≡ "*" then
+ abort $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: *"
+ else
+ case P.parseOnly (finishOff def) (cs value) of
+ Right []
+ → abort $ mkAbortion' BadRequest
+ $ "Empty If-None-Match"
+ Right tags
+ → when (any (≡ tag) tags)
+ $ abort
+ $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: " ⊕ cs value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-None-Match: " ⊕ cs value
+
+ driftTo ReceivingBody
+
+-- |Tell the system that the 'Rsrc' 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 → Rsrc ()
+foundTimeStamp timeStamp
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "Last-Modified"
+ $ formatUTCTime timeStamp
+ when (method ≡ POST)
+ $ abort
+ $ mkAbortion' InternalServerError
+ "Illegal call of foundTimeStamp for POST request."
+
+ let statusForIfModSince
+ = if method ≡ GET ∨ method ≡ HEAD then
+ fromStatusCode NotModified
+ else
+ fromStatusCode PreconditionFailed
+
+ ifModSince ← getHeader "If-Modified-Since"
+ case ifModSince of
+ Just str → case untag' <$> (fromAttempt $ ca str) of
+ Just lastTime
+ → when (timeStamp ≤ lastTime)
+ $ abort
+ $ mkAbortion' statusForIfModSince
+ $ "The entity has not been modified since " ⊕ cs str
+ Nothing
+ → abort $ mkAbortion' BadRequest
+ $ "Malformed If-Modified-Since: " ⊕ cs str
+ Nothing → return ()
+
+ ifUnmodSince ← getHeader "If-Unmodified-Since"
+ case ifUnmodSince of
+ Just str → case untag' <$> (fromAttempt $ ca str) of
+ Just lastTime
+ → when (timeStamp > lastTime)
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity has not been modified since " ⊕ cs str
+ Nothing
+ → abort $ mkAbortion' BadRequest
+ $ "Malformed If-Unmodified-Since: " ⊕ cs str
+ Nothing → return ()
+
+ driftTo ReceivingBody
+ where
+ untag' ∷ Tagged HTTP α → α
+ {-# INLINE untag' #-}
+ untag' = untag