module Network.Salvia.Handler.Body
( hRawRequestBody
, hRawResponseBody
, hRawBody
, hRequestBodyText
, hResponseBodyText
, hBodyText
, hRequestBodyStringUTF8
, hResponseBodyStringUTF8
, hBodyStringUTF8
, hRequestParameters
, hResponseParameters
, hParameters
)
where
import Control.Applicative
import Control.Monad.State hiding (get)
import Data.Char
import Data.Record.Label
import Data.Text.Lazy (Text, unpack)
import Data.Text.Lazy.Encoding
import Network.Protocol.Http
import Network.Protocol.Uri
import Network.Salvia.Interface
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.UTF8 as U
encodingFromName :: String -> Maybe (B.ByteString -> Text)
encodingFromName s = k `lookup`
[ ("utf8", decodeUtf8)
] where k = map toLower (filter (\c -> isAlpha c || isDigit c) s)
hRawBody :: forall m d. (MonadIO m, HandleM m, HttpM d m) => d -> m B.ByteString
hRawBody _ =
do let h = http :: State (Http d) a -> m a
con <- h (getM connection)
kpa <- h (getM keepAlive)
len <- h (getM contentLength)
s <- handle
liftIO $
case (con, kpa :: Maybe Integer, len :: Maybe Integer) of
(_, _, Just n) -> B.hGet s (fromIntegral n)
(k, Nothing, Nothing) | k /= Just "keep-alive" -> B.hGetContents s
_ -> return B.empty
hRawRequestBody :: BodyM Request m => m B.ByteString
hRawRequestBody = body forRequest
hRawResponseBody :: BodyM Response m => m B.ByteString
hRawResponseBody = body forResponse
hBodyText :: forall m dir. (BodyM dir m, HttpM dir m) => dir -> String -> m Text
hBodyText d def =
do let h = http :: State (Http dir) a -> m a
c <- body d
e <- (>>= snd) <$> h (getM contentType) :: m (Maybe String)
return $
case (e >>= encodingFromName, encodingFromName def) of
(Just enc, _) -> enc c
(_, Just enc) -> enc c
(_, _) -> error "hBodyText: wrong default encoding specified"
hRequestBodyText :: (BodyM Request m, HttpM Request m) => String -> m Text
hRequestBodyText = hBodyText forRequest
hResponseBodyText :: (BodyM Response m, HttpM Response m) => String -> m Text
hResponseBodyText = hBodyText forResponse
hBodyStringUTF8 :: BodyM dir m => dir -> m String
hBodyStringUTF8 d = U.toString <$> body d
hRequestBodyStringUTF8 :: BodyM Request m => m String
hRequestBodyStringUTF8 = hBodyStringUTF8 forRequest
hResponseBodyStringUTF8 :: BodyM Response m => m String
hResponseBodyStringUTF8 = hBodyStringUTF8 forResponse
hParameters :: (BodyM d m, HttpM d m) => d -> String -> m Parameters
hParameters d def = fw params . unpack <$> hBodyText d def
hRequestParameters :: (BodyM Request m, HttpM Request m) => String -> m Parameters
hRequestParameters = hParameters forRequest
hResponseParameters :: (BodyM Response m, HttpM Response m) => String -> m Parameters
hResponseParameters = hParameters forResponse