module Network.Wai.Util (
handleAcceptTypes,
noStoreFileUploads,
#if !MIN_VERSION_wai(2,0,0)
bodyBytestring,
#endif
mapHeaders,
defHeader,
defHeader',
replaceHeader,
replaceHeader',
string,
text,
textBuilder,
json,
bytestring,
redirect,
redirect',
stringAscii,
stringHeader,
stringHeaders,
stringHeaders',
responseToMailPart,
queryLookup,
queryLookupAll
) where
import Data.Char (isAscii)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.List (intercalate)
import Data.Monoid (mappend, mempty)
import Control.Monad (liftM2,join)
import Control.Arrow ((***))
import Data.String (IsString, fromString)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Network.URI (URI, uriIsAbsolute)
import Network.HTTP.Types (statusIsRedirection, Status, ResponseHeaders, Header, notAcceptable406)
import Network.HTTP.Types.QueryLike (QueryLike, QueryKeyLike, toQuery, toQueryKey)
import Network.Wai (Request, responseLBS, requestBody, requestHeaders)
#if MIN_VERSION_wai(2,0,0)
import Network.Wai (responseToSource)
import Network.Wai.Internal (Response(ResponseBuilder,ResponseFile,ResponseSource))
#else
import Network.Wai (Response(ResponseBuilder,ResponseFile,ResponseSource), responseSource)
#endif
import Network.Wai.Parse (BackEnd, parseHttpAccept)
import Network.Mail.Mime (Part(..), Encoding(QuotedPrintableText, Base64))
import Control.Monad.Trans.Resource (runResourceT, ResourceT)
import Data.Conduit (($$), Flush(Chunk))
import Data.Conduit.List (fold, sinkNull)
import Network.HTTP.Accept (selectAcceptType)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.ByteString.Lazy as LZ
import qualified Blaze.ByteString.Builder as Builder
import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder
import qualified Data.Aeson as Aeson
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Builder as TL
import qualified Data.CaseInsensitive as CI
handleAcceptTypes :: (Monad m) => [(String, m Response)] -> Request -> m Response
handleAcceptTypes handlers req =
fromMaybe notAcceptable handler
where
handler = lookup acceptType handlers
notAcceptable = string notAcceptable406 [] (intercalate "\n" supportedTypes)
acceptType = fromMaybe (head supportedTypes) acceptType'
acceptType' = (selectAcceptType supportedTypes . parseHttpAccept) =<<
lookup (fromString "Accept") (requestHeaders req)
supportedTypes = map fst handlers
noStoreFileUploads :: BackEnd ()
noStoreFileUploads _ _ = sinkNull
#if !MIN_VERSION_wai(2,0,0)
bodyBytestring :: Request -> ResourceT IO ByteString
bodyBytestring req = requestBody req $$ fold mappend mempty
#endif
mapHeaders :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapHeaders f (ResponseFile s h b1 b2) = ResponseFile s (f h) b1 b2
mapHeaders f (ResponseBuilder s h b) = ResponseBuilder s (f h) b
mapHeaders f (ResponseSource s h b) = ResponseSource s (f h) b
defHeader :: Header -> Response -> Response
defHeader h = mapHeaders (defHeader' h)
defHeader' :: Header -> ResponseHeaders -> ResponseHeaders
defHeader' (n, v) headers = case lookup n headers of
Just _ -> headers
Nothing -> (n, v):headers
replaceHeader :: Header -> Response -> Response
replaceHeader h = mapHeaders (replaceHeader' h)
replaceHeader' :: Header -> ResponseHeaders -> ResponseHeaders
replaceHeader' (n, v) = ((n,v):) . filter ((/=n) . fst)
string :: (Monad m) => Status -> ResponseHeaders -> String -> m Response
string status headers = return . defHeader defCT . ResponseBuilder status headers . Builder.fromString
where
Just defCT = stringHeader ("Content-Type", "text/plain; charset=utf-8")
text :: (Monad m) => Status -> ResponseHeaders -> Text -> m Response
text status headers = return . defHeader defCT . ResponseBuilder status headers . Builder.fromText
where
Just defCT = stringHeader ("Content-Type", "text/plain; charset=utf-8")
textBuilder :: (Monad m) => Status -> ResponseHeaders -> TL.Builder -> m Response
textBuilder status headers = return . defHeader defCT . ResponseBuilder status headers . Builder.fromLazyText . TL.toLazyText
where
Just defCT = stringHeader ("Content-Type", "text/plain; charset=utf-8")
json :: (Monad m, Aeson.ToJSON a) => Status -> ResponseHeaders -> a -> m Response
json status headers = return . defHeader defCT . responseLBS status headers . Aeson.encode . Aeson.toJSON
where
Just defCT = stringHeader ("Content-Type", "application/json; charset=utf-8")
class IsByteString a where
bytestringToBuilder :: a -> Builder.Builder
instance IsByteString ByteString where
bytestringToBuilder = Builder.fromByteString
instance IsByteString LZ.ByteString where
bytestringToBuilder = Builder.fromLazyByteString
bytestring :: (IsByteString bs, Monad m) => Status -> ResponseHeaders -> bs -> m Response
bytestring status headers = return . defHeader defCT . ResponseBuilder status headers . bytestringToBuilder
where
Just defCT = stringHeader ("Content-Type", "application/octet-stream")
redirect :: Status -> ResponseHeaders -> URI -> Maybe Response
redirect status headers uri
| statusIsRedirection status && uriIsAbsolute uri = do
uriBS <- stringAscii (show uri)
return $ responseLBS status ((location, uriBS):headers) mempty
| otherwise = Nothing
where
Just location = stringAscii "Location"
redirect' :: (Monad m) => Status -> ResponseHeaders -> URI -> m Response
redirect' status headers uri =
let Just r = redirect status headers uri in return r
stringAscii :: (IsString s) => String -> Maybe s
stringAscii s
| all isAscii s = Just (fromString s)
| otherwise = Nothing
stringHeader :: (IsString s1, IsString s2) => (String, String) -> Maybe (s1, s2)
stringHeader (n, v) = liftM2 (,) (stringAscii n) (stringAscii v)
stringHeaders :: (IsString s1, IsString s2) => [(String, String)] -> Maybe [(s1, s2)]
stringHeaders = mapM stringHeader
stringHeaders' :: (IsString s1, IsString s2) => [(String, String)] -> [(s1, s2)]
stringHeaders' hs = let Just headers = stringHeaders hs in headers
responseToMailPart :: (MonadIO m) => Bool -> Response -> m Part
responseToMailPart asTxt r = do
body <- liftIO $ Builder.toLazyByteString `fmap` builderBody
return $ Part (T.decodeUtf8 contentType) contentEncode Nothing headers body
where
chunkFlatAppend m (Chunk more) = m `mappend` more
chunkFlatAppend m _ = m
headers = map (CI.original *** T.decodeUtf8) $ filter ((/=contentTypeName) . fst) headers'
contentType = fromMaybe defContentType $ lookup contentTypeName headers'
contentEncode | asTxt = QuotedPrintableText
| otherwise = Base64
defContentType | asTxt = fromString "text/plain; charset=utf-8"
| otherwise = fromString "application/octet-stream"
#if MIN_VERSION_wai(2,0,0)
builderBody = body' ($$ fold chunkFlatAppend mempty)
(_, headers', body') = responseToSource r
#else
builderBody = runResourceT $ body' $$ fold chunkFlatAppend mempty
(_, headers', body') = responseSource r
#endif
contentTypeName = fromString "Content-Type"
queryLookup :: (QueryLike q, QueryKeyLike k) => k -> q -> Maybe Text
queryLookup k = fmap (T.decodeUtf8With lenientDecode) . join . lookup (toQueryKey k) . toQuery
queryLookupAll :: (QueryLike q, QueryKeyLike k) => k -> q -> [Text]
queryLookupAll k = map (T.decodeUtf8With lenientDecode) . mapMaybe f . toQuery
where
f (ik, mv)
| ik == k' = mv
| otherwise = Nothing
k' = toQueryKey k