module Network.HTTP.Lucu.Resource
(
Resource
, FormData(..)
, runRes
, getConfig
, getRemoteAddr
, getRemoteAddr'
, getRemoteHost
, getRemoteCertificate
, getRequest
, getMethod
, getRequestURI
, getRequestVersion
, getResourcePath
, getPathInfo
, getQueryForm
, getHeader
, getAccept
, getAcceptEncoding
, isEncodingAcceptable
, getContentType
, getAuthorization
, foundEntity
, foundETag
, foundTimeStamp
, foundNoEntity
, input
, inputChunk
, inputLBS
, inputChunkLBS
, inputForm
, defaultLimit
, setStatus
, setHeader
, redirect
, setContentType
, setLocation
, setContentEncoding
, setWWWAuthenticate
, output
, outputChunk
, outputLBS
, outputChunkLBS
, driftTo
)
where
import Control.Concurrent.STM
import Control.Monad.Reader
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
import Data.Char
import Data.List
import Data.Maybe
import Data.Time
import qualified Data.Time.HTTP as HTTP
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Authorization
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.ContentCoding
import Network.HTTP.Lucu.DefaultPage
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.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
newtype Resource a = Resource { unRes :: ReaderT Interaction IO a }
instance Functor Resource where
fmap f c = Resource (fmap f (unRes c))
instance Monad Resource where
c >>= f = Resource (unRes c >>= unRes . f)
return = Resource . return
fail = Resource . fail
instance MonadIO Resource where
liftIO = Resource . liftIO
runRes :: Resource a -> Interaction -> IO a
runRes r itr
= runReaderT (unRes r) itr
getInteraction :: Resource Interaction
getInteraction = Resource ask
getConfig :: Resource Config
getConfig = do itr <- getInteraction
return $! itrConfig itr
getRemoteAddr :: Resource SockAddr
getRemoteAddr = do itr <- getInteraction
return $! itrRemoteAddr itr
getRemoteAddr' :: Resource String
getRemoteAddr' = do addr <- getRemoteAddr
(Just str, _) <- liftIO $! getNameInfo [NI_NUMERICHOST] True False addr
return str
getRemoteHost :: Resource String
getRemoteHost = do addr <- getRemoteAddr
(Just str, _) <- liftIO $! getNameInfo [] True False addr
return str
getRemoteCertificate :: Resource (Maybe X509)
getRemoteCertificate = do itr <- getInteraction
return $! itrRemoteCert itr
getRequest :: Resource Request
getRequest = do itr <- getInteraction
req <- liftIO $! atomically $! readItr itr itrRequest fromJust
return req
getMethod :: Resource Method
getMethod = do req <- getRequest
return $! reqMethod req
getRequestURI :: Resource URI
getRequestURI = do req <- getRequest
return $! reqURI req
getRequestVersion :: Resource HttpVersion
getRequestVersion = do req <- getRequest
return $! reqVersion req
getResourcePath :: Resource [String]
getResourcePath = do itr <- getInteraction
return $! fromJust $! itrResourcePath itr
getPathInfo :: Resource [String]
getPathInfo = do rsrcPath <- getResourcePath
uri <- getRequestURI
let reqPathStr = uriPath uri
reqPath = [unEscapeString x | x <- splitBy (== '/') reqPathStr, x /= ""]
return $! drop (length rsrcPath) reqPath
getQueryForm :: Resource [(String, FormData)]
getQueryForm = liftM parse' getRequestURI
where
parse' = map toPairWithFormData .
parseWWWFormURLEncoded .
snd .
splitAt 1 .
uriQuery
toPairWithFormData :: (String, String) -> (String, FormData)
toPairWithFormData (name, value)
= let fd = FormData {
fdFileName = Nothing
, fdContent = L8.pack value
}
in (name, fd)
getHeader :: Strict.ByteString -> Resource (Maybe Strict.ByteString)
getHeader name = name `seq`
do req <- getRequest
return $! H.getHeader name req
getAccept :: Resource [MIMEType]
getAccept = do acceptM <- getHeader (C8.pack "Accept")
case acceptM of
Nothing
-> return []
Just accept
-> case parse mimeTypeListP (L8.fromChunks [accept]) of
(# Success xs, _ #) -> return xs
(# _ , _ #) -> abort BadRequest []
(Just $ "Unparsable Accept: " ++ C8.unpack accept)
getAcceptEncoding :: Resource [(String, Maybe Double)]
getAcceptEncoding
= do accEncM <- getHeader (C8.pack "Accept-Encoding")
case accEncM of
Nothing
-> do ver <- getRequestVersion
case ver of
HttpVersion 1 0 -> return [("identity", Nothing)]
HttpVersion 1 1 -> return [("*" , Nothing)]
_ -> undefined
Just value
-> if C8.null value then
return [("identity", Nothing)]
else
case parse acceptEncodingListP (L8.fromChunks [value]) of
(# Success x, _ #) -> return $ reverse $ sortBy orderAcceptEncodings x
(# _ , _ #) -> abort BadRequest []
(Just $ "Unparsable Accept-Encoding: " ++ C8.unpack value)
isEncodingAcceptable :: String -> Resource Bool
isEncodingAcceptable coding
= do accList <- getAcceptEncoding
return (flip any accList $ \ (c, q) ->
(c == "*" || C8.pack c `H.noCaseEq` C8.pack coding) && q /= Just 0)
getContentType :: Resource (Maybe MIMEType)
getContentType
= do cTypeM <- getHeader (C8.pack "Content-Type")
case cTypeM of
Nothing
-> return Nothing
Just cType
-> case parse mimeTypeP (L8.fromChunks [cType]) of
(# Success t, _ #) -> return $ Just t
(# _ , _ #) -> abort BadRequest []
(Just $ "Unparsable Content-Type: " ++ C8.unpack cType)
getAuthorization :: Resource (Maybe AuthCredential)
getAuthorization
= do authM <- getHeader (C8.pack "Authorization")
case authM of
Nothing
-> return Nothing
Just auth
-> case parse authCredentialP (L8.fromChunks [auth]) of
(# Success a, _ #) -> return $ Just a
(# _ , _ #) -> return Nothing
foundEntity :: ETag -> UTCTime -> Resource ()
foundEntity tag timeStamp
= tag `seq` timeStamp `seq`
do driftTo ExaminingRequest
method <- getMethod
when (method == GET || method == HEAD)
$ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format timeStamp)
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundEntity for a POST request.")
foundETag tag
driftTo GettingBody
foundETag :: ETag -> Resource ()
foundETag tag
= tag `seq`
do driftTo ExaminingRequest
method <- getMethod
when (method == GET || method == HEAD)
$ setHeader' (C8.pack "ETag") (C8.pack $ show tag)
when (method == POST)
$ abort InternalServerError []
(Just "Illegal computation of foundETag for POST request.")
ifMatch <- getHeader (C8.pack "If-Match")
case ifMatch of
Nothing -> return ()
Just value -> if value == C8.pack "*" then
return ()
else
case parse eTagListP (L8.fromChunks [value]) of
(# Success tags, _ #)
-> when (not $ any (== tag) tags)
$ abort PreconditionFailed []
$! Just ("The entity tag doesn't match: " ++ C8.unpack value)
(# _, _ #)
-> abort BadRequest [] $! Just ("Unparsable If-Match: " ++ C8.unpack value)
let statusForNoneMatch = if method == GET || method == HEAD then
NotModified
else
PreconditionFailed
ifNoneMatch <- getHeader (C8.pack "If-None-Match")
case ifNoneMatch of
Nothing -> return ()
Just value -> if value == C8.pack "*" then
abort statusForNoneMatch [] $! Just ("The entity tag matches: *")
else
case parse eTagListP (L8.fromChunks [value]) of
(# Success tags, _ #)
-> when (any (== tag) tags)
$ abort statusForNoneMatch [] $! Just ("The entity tag matches: " ++ C8.unpack value)
(# _, _ #)
-> abort BadRequest [] $! Just ("Unparsable If-None-Match: " ++ C8.unpack value)
driftTo GettingBody
foundTimeStamp :: UTCTime -> Resource ()
foundTimeStamp timeStamp
= timeStamp `seq`
do driftTo ExaminingRequest
method <- getMethod
when (method == GET || method == HEAD)
$ setHeader' (C8.pack "Last-Modified") (C8.pack $ HTTP.format 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
ifModSince <- getHeader (C8.pack "If-Modified-Since")
case ifModSince of
Just str -> case HTTP.parse (C8.unpack str) of
Just lastTime
-> when (timeStamp <= lastTime)
$ abort statusForIfModSince []
$! Just ("The entity has not been modified since " ++ C8.unpack str)
Nothing
-> return ()
Nothing -> return ()
ifUnmodSince <- getHeader (C8.pack "If-Unmodified-Since")
case ifUnmodSince of
Just str -> case HTTP.parse (C8.unpack str) of
Just lastTime
-> when (timeStamp > lastTime)
$ abort PreconditionFailed []
$! Just ("The entity has not been modified since " ++ C8.unpack str)
Nothing
-> return ()
Nothing -> return ()
driftTo GettingBody
foundNoEntity :: Maybe String -> Resource ()
foundNoEntity msgM
= msgM `seq`
do driftTo ExaminingRequest
method <- getMethod
when (method /= PUT)
$ abort NotFound [] msgM
ifMatch <- getHeader (C8.pack "If-Match")
when (ifMatch /= Nothing)
$ abort PreconditionFailed [] msgM
driftTo GettingBody
input :: Int -> Resource String
input limit = limit `seq`
inputLBS limit >>= return . L8.unpack
inputLBS :: Int -> Resource Lazy.ByteString
inputLBS limit
= limit `seq`
do driftTo GettingBody
itr <- getInteraction
hasBody <- liftIO $! atomically $! readItr itr itrRequestHasBody id
chunk <- if hasBody then
askForInput itr
else
do driftTo DecidingHeader
return L8.empty
return chunk
where
askForInput :: Interaction -> Resource Lazy.ByteString
askForInput itr
= itr `seq`
do let confLimit = cnfMaxEntityLength $ itrConfig itr
actualLimit = if limit <= 0 then
confLimit
else
limit
when (actualLimit <= 0)
$ fail ("inputLBS: limit must be positive: " ++ show actualLimit)
liftIO $! atomically
$! do chunkLen <- readItr itr itrReqChunkLength id
writeItr itr itrWillReceiveBody True
if fmap (> actualLimit) chunkLen == Just True then
tooLarge actualLimit
else
writeItr itr itrReqBodyWanted $ Just actualLimit
chunk <- liftIO $! atomically
$! do chunk <- readItr itr itrReceivedBody id
chunkIsOver <- readItr itr itrReqChunkIsOver id
if L8.length chunk < fromIntegral actualLimit then
unless chunkIsOver
$ retry
else
unless chunkIsOver
$ tooLarge actualLimit
writeItr itr itrReceivedBody L8.empty
return chunk
driftTo DecidingHeader
return chunk
tooLarge :: Int -> STM ()
tooLarge lim = lim `seq`
abortSTM RequestEntityTooLarge []
$! Just ("Request body must be smaller than "
++ show lim ++ " bytes.")
inputChunk :: Int -> Resource String
inputChunk limit = limit `seq`
inputChunkLBS limit >>= return . L8.unpack
inputChunkLBS :: Int -> Resource Lazy.ByteString
inputChunkLBS limit
= limit `seq`
do driftTo GettingBody
itr <- getInteraction
hasBody <- liftIO $ atomically $ readItr itr itrRequestHasBody id
chunk <- if hasBody then
askForInput itr
else
do driftTo DecidingHeader
return L8.empty
return chunk
where
askForInput :: Interaction -> Resource Lazy.ByteString
askForInput itr
= itr `seq`
do let confLimit = cnfMaxEntityLength $! itrConfig itr
actualLimit = if limit < 0 then
confLimit
else
limit
when (actualLimit <= 0)
$ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
liftIO $! atomically
$! do writeItr itr itrReqBodyWanted $! Just actualLimit
writeItr itr itrWillReceiveBody True
chunk <- liftIO $! atomically
$ do chunk <- readItr itr itrReceivedBody id
when (L8.length chunk < fromIntegral actualLimit)
$ do chunkIsOver <- readItr itr itrReqChunkIsOver id
unless chunkIsOver
$ retry
writeItr itr itrReceivedBody L8.empty
return chunk
when (L8.null chunk)
$ driftTo DecidingHeader
return chunk
inputForm :: Int -> Resource [(String, FormData)]
inputForm limit
= limit `seq`
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 $! "Unsupported media type: "
++ show cType)
where
readWWWFormURLEncoded
= liftM (map toPairWithFormData . parseWWWFormURLEncoded) (input limit)
readMultipartFormData params
= do case find ((== "boundary") . map toLower . fst) params of
Nothing
-> abort BadRequest [] (Just "Missing boundary of multipart/form-data")
Just (_, boundary)
-> do src <- inputLBS limit
case parse (multipartFormP boundary) src of
(# Success formList, _ #)
-> return formList
(# _, _ #)
-> abort BadRequest [] (Just "Unparsable multipart/form-data")
defaultLimit :: Int
defaultLimit = (1)
setStatus :: StatusCode -> Resource ()
setStatus code
= code `seq`
do driftTo DecidingHeader
itr <- getInteraction
liftIO $! atomically $! updateItr itr itrResponse
$! \ res -> res {
resStatus = code
}
setHeader :: Strict.ByteString -> Strict.ByteString -> Resource ()
setHeader name value
= name `seq` value `seq`
driftTo DecidingHeader >> setHeader' name value
setHeader' :: Strict.ByteString -> Strict.ByteString -> Resource ()
setHeader' name value
= name `seq` value `seq`
do itr <- getInteraction
liftIO $ atomically
$ updateItr itr itrResponse
$ H.setHeader name value
redirect :: StatusCode -> URI -> Resource ()
redirect code uri
= code `seq` uri `seq`
do when (code == NotModified || not (isRedirection code))
$ abort InternalServerError []
$! Just ("Attempted to redirect with status " ++ show code)
setStatus code
setLocation uri
setContentType :: MIMEType -> Resource ()
setContentType mType
= setHeader (C8.pack "Content-Type") (C8.pack $ show mType)
setLocation :: URI -> Resource ()
setLocation uri
= setHeader (C8.pack "Location") (C8.pack $ uriToString id uri $ "")
setContentEncoding :: [String] -> Resource ()
setContentEncoding codings
= do ver <- getRequestVersion
let tr = case ver of
HttpVersion 1 0 -> unnormalizeCoding
HttpVersion 1 1 -> id
_ -> undefined
setHeader (C8.pack "Content-Encoding") (C8.pack $ joinWith ", " $ map tr codings)
setWWWAuthenticate :: AuthChallenge -> Resource ()
setWWWAuthenticate challenge
= setHeader (C8.pack "WWW-Authenticate") (C8.pack $ show challenge)
output :: String -> Resource ()
output str = outputLBS $! L8.pack str
outputLBS :: Lazy.ByteString -> Resource ()
outputLBS str = do outputChunkLBS str
driftTo Done
outputChunk :: String -> Resource ()
outputChunk str = outputChunkLBS $! L8.pack str
outputChunkLBS :: Lazy.ByteString -> Resource ()
outputChunkLBS wholeChunk
= wholeChunk `seq`
do driftTo DecidingBody
itr <- getInteraction
let limit = cnfMaxOutputChunkLength $ itrConfig itr
when (limit <= 0)
$ fail ("cnfMaxOutputChunkLength must be positive: "
++ show limit)
discardBody <- liftIO $ atomically $
readItr itr itrWillDiscardBody id
unless (discardBody)
$ sendChunks wholeChunk limit
unless (L8.null wholeChunk)
$ liftIO $ atomically $
writeItr itr itrBodyIsNull False
where
sendChunks :: Lazy.ByteString -> Int -> Resource ()
sendChunks str limit
| L8.null str = return ()
| otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
itr <- getInteraction
liftIO $ atomically $
do buf <- readItr itr itrBodyToSend id
if L8.null buf then
writeItr itr itrBodyToSend chunk
else
retry
sendChunks remaining limit
driftTo :: InteractionState -> Resource ()
driftTo newState
= newState `seq`
do itr <- getInteraction
liftIO $ atomically $ do oldState <- readItr itr itrState id
if newState < oldState then
throwStateError oldState newState
else
do let a = [oldState .. newState]
b = tail a
c = zip a b
mapM_ (uncurry $ drift itr) c
writeItr itr itrState newState
where
throwStateError :: Monad m => InteractionState -> InteractionState -> m a
throwStateError Done DecidingBody
= fail "It makes no sense to output something after finishing to output."
throwStateError old new
= fail ("state error: " ++ show old ++ " ==> " ++ show new)
drift :: Interaction -> InteractionState -> InteractionState -> STM ()
drift itr GettingBody _
= writeItr itr itrReqBodyWasteAll True
drift itr DecidingHeader _
= postprocess itr
drift itr _ Done
= do bodyIsNull <- readItr itr itrBodyIsNull id
when bodyIsNull
$ writeDefaultPage itr
drift _ _ _
= return ()