+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.MultipartForm
+import Network.HTTP.Lucu.Postprocess
+import Network.HTTP.Lucu.Request
+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 OpenSSL.X509
+import Prelude.Unicode
+
+-- |The 'Resource' monad. This monad implements 'MonadIO' so it can do
+-- any 'IO' actions.
+newtype Resource a
+ = Resource {
+ unRes ∷ ReaderT Interaction IO a
+ }
+ deriving (Applicative, Functor, Monad, MonadIO)
+
+runRes ∷ Resource a → Interaction → IO a
+runRes r itr
+ = runReaderT (unRes r) itr
+
+getInteraction ∷ Resource Interaction
+getInteraction = Resource ask
+
+-- |Get the 'Config' value which is used for the httpd.
+getConfig ∷ Resource Config
+getConfig = itrConfig <$> getInteraction
+
+-- |Get the 'SockAddr' of the remote host. If you want a string
+-- representation instead of 'SockAddr', use 'getRemoteAddr''.
+getRemoteAddr ∷ Resource SockAddr
+getRemoteAddr = itrRemoteAddr <$> getInteraction
+
+-- |Get the string representation of the address of remote host. If
+-- you want a 'SockAddr' instead of 'String', use 'getRemoteAddr'.
+getRemoteAddr' ∷ Resource HostName
+getRemoteAddr'
+ = do sa ← getRemoteAddr
+ (Just a, _) ← liftIO $ getNameInfo [NI_NUMERICHOST] False False sa
+ return a
+
+-- |Resolve an address to the remote host.
+getRemoteHost ∷ Resource (Maybe HostName)
+getRemoteHost
+ = do sa ← getRemoteAddr
+ fst <$> (liftIO $ getNameInfo [] True False sa)
+
+-- | Return the X.509 certificate of the client, or 'Nothing' if:
+--
+-- * This request didn't came through an SSL stream.
+--
+-- * The client didn't send us its certificate.
+--
+-- * The 'OpenSSL.Session.VerificationMode' of
+-- 'OpenSSL.Session.SSLContext' in 'SSLConfig' has not been set to
+-- 'OpenSSL.Session.VerifyPeer'.
+getRemoteCertificate ∷ Resource (Maybe X509)
+getRemoteCertificate = itrRemoteCert <$> getInteraction
+
+-- |Get the 'Request' value which represents the request header. In
+-- general you don't have to use this action.
+getRequest ∷ Resource Request
+getRequest
+ = do itr ← getInteraction
+ liftIO $ atomically $ readItr itrRequest fromJust itr
+
+-- |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
+
+-- |Get the path of this 'Resource' (to be exact,
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef') in the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResTree'. The result of this
+-- action is the exact path in the tree even if the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is greedy.
+--
+-- Example:
+--
+-- > main = let tree = mkResTree [ (["foo"], resFoo) ]
+-- > in runHttpd defaultConfig tree
+-- >
+-- > resFoo = ResourceDef {
+-- > resIsGreedy = True
+-- > , resGet = Just $ do requestURI ← getRequestURI
+-- > resourcePath ← getResourcePath
+-- > pathInfo ← getPathInfo
+-- > -- uriPath requestURI == "/foo/bar/baz"
+-- > -- resourcePath == ["foo"]
+-- > -- pathInfo == ["bar", "baz"]
+-- > ...
+-- > , ...
+-- > }
+getResourcePath ∷ Resource [Ascii]
+getResourcePath = (fromJust ∘ itrResourcePath) <$> getInteraction
+
+-- |This is an analogy of CGI PATH_INFO. The result is
+-- URI-unescaped. It is always @[]@ if the
+-- 'Network.HTTP.Lucu.Resource.Tree.ResourceDef' is not greedy. See
+-- 'getResourcePath'.
+getPathInfo ∷ Resource [ByteString]
+getPathInfo = do rsrcPath ← getResourcePath
+ uri ← getRequestURI
+ let reqPathStr = uriPath uri
+ reqPath = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
+ -- rsrcPath と reqPath の共通する先頭部分を reqPath か
+ -- ら全部取り除くと、それは PATH_INFO のやうなものにな
+ -- る。rsrcPath は全部一致してゐるに決まってゐる(でな
+ -- ければこの Resource が撰ばれた筈が無い)ので、
+ -- rsrcPath の長さの分だけ削除すれば良い。
+ return $ map C8.pack $ drop (length rsrcPath) reqPath
+
+-- |Assume the query part of request URI as
+-- application\/x-www-form-urlencoded, and parse it to pairs of
+-- @(name, formData)@. This action doesn't parse the request body. See
+-- 'inputForm'. Field names are decoded in UTF-8.
+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 = L8.fromChunks [value]
+ }
+ in (T.decodeUtf8With T.lenientDecode name, fd)
+
+-- |Get a value of given request header. Comparison of header name is
+-- case-insensitive. Note that this action 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
+
+-- |Get a list of 'MIMEType' enumerated on header \"Accept\".
+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
+
+-- |Get a list of @(contentCoding, qvalue)@ enumerated on 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