module Network.Wai.Util where
import Data.Char (isAscii)
import Data.Maybe (fromMaybe)
import Data.Monoid (mappend, mempty)
import Control.Monad (liftM2)
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)
import Network.Wai (Request, Response(ResponseBuilder,ResponseFile,ResponseSource), responseLBS, requestBody, responseSource)
import Network.Wai.Parse (BackEnd)
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 Data.ByteString (ByteString)
import Data.Text (Text)
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.CaseInsensitive as CI
noStoreFileUploads :: BackEnd ()
noStoreFileUploads _ _ = sinkNull
bodyBytestring :: Request -> ResourceT IO ByteString
bodyBytestring req = requestBody req $$ fold mappend mempty
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 :: (MonadIO 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 :: (MonadIO 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")
json :: (MonadIO 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")
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"
builderBody = runResourceT $ body' $$ fold chunkFlatAppend mempty
(_, headers', body') = responseSource r
contentTypeName = fromString "Content-Type"