1 {-# LANGUAGE TypeSynonymInstances, DeriveDataTypeable, OverloadedStrings #-} 2 module Databrary.Action.Response 3 ( Response 4 , ResponseData(..) 5 , emptyResponse 6 , okResponse 7 , result 8 , unsafeResult 9 , runResult 10 , proxyResponse 11 ) where 12 13 import Conduit (Source, (.|)) 14 import Control.Exception (Exception, throwIO, throw, handle) 15 import Control.Monad (join) 16 import Control.Monad.IO.Class (MonadIO, liftIO) 17 import Data.Typeable (Typeable) 18 import Network.HTTP.Types (ResponseHeaders, Status, ok200, hContentType) 19 import Network.Wai 20 ( Response 21 , responseBuilder 22 , responseLBS 23 , StreamingBody 24 , responseStream 25 , FilePart(..) 26 , responseFile 27 , responseStatus 28 ) 29 import System.Posix.Types (FileOffset) 30 import qualified Conduit as CND 31 import qualified Data.Binary.Builder as DBB 32 import qualified Data.ByteString as BS 33 import qualified Data.ByteString.Builder as BSB 34 import qualified Data.ByteString.Lazy as BSL 35 import qualified Data.Text as T 36 import qualified Data.Text.Encoding as TE 37 import qualified Data.Text.Lazy as TL 38 import qualified Data.Text.Lazy.Encoding as TLE 39 import qualified Network.HTTP.Client as HC 40 import qualified Text.Blaze.Html as Html 41 import qualified Text.Blaze.Html.Renderer.Utf8 as Html 42 43 import qualified Databrary.JSON as JSON 44 45 -- | This class captures Databrary's mechanism for creating 'Response's from the 46 -- values actually returned by handlers. 47 -- 48 -- It is rather general. A value can be turned into a response either by 49 -- modifying headers or by using one of Wai's Response composers (e.g. 50 -- 'responseBuilder'). There are some rather esoteric instances. 51 -- 52 -- Similar mechanisms in Servant or Yesod generally restrict themselves to 53 -- building response *data* out of return values, without explicit mention of 54 -- 'Response'. See e.g. 55 -- <http://hackage.haskell.org/package/http-api-data-0.3.8.1/docs/Web-HttpApiData.html> 56 -- 57 -- Servant also has 58 -- <http://hackage.haskell.org/package/servant-0.13.0.1/docs/Servant-API-ContentTypes.html#t:MimeRender MimeRender>, 59 -- which describes how to create a ByteString for use in creating Responses. 60 class ResponseData r where 61 response :: Status -> ResponseHeaders -> r -> Response 62 63 instance ResponseData BSB.Builder where 64 response = responseBuilder 65 66 instance ResponseData BSL.ByteString where 67 response = responseLBS 68 69 instance ResponseData BS.ByteString where 70 response s h = responseBuilder s h . BSB.byteString 71 72 instance ResponseData (Source (CND.ResourceT IO) BS.ByteString) where 73 response s h src = 74 responseStream s h 75 (\send _ -> do 76 CND.runConduitRes 77 (src 78 .| (CND.mapM_C 79 (\bs -> CND.lift (send (DBB.fromByteString bs)))))) 80 81 instance ResponseData StreamingBody where 82 response = responseStream 83 84 instance ResponseData ((BS.ByteString -> IO ()) -> IO ()) where 85 response s h f = responseStream s h (\w l -> f (\b -> if BS.null b then l else w (BSB.byteString b))) 86 87 instance ResponseData (FilePath, Maybe FilePart) where 88 response s h (f, p) = responseFile s h f p 89 90 instance ResponseData (FilePath, FilePart) where 91 response s h (f, p) = response s h (f, Just p) 92 93 instance ResponseData (FilePath, Maybe FileOffset) where 94 response s h (f, z) = response s h (f, join (FilePart 0) . toInteger <$> z) 95 96 instance ResponseData String where 97 response s h = 98 response s ((hContentType, "text/plain;charset=utf-8") : h) . BSB.stringUtf8 99 100 instance ResponseData T.Text where 101 response s h = 102 response s ((hContentType, "text/plain;charset=utf-8") : h) . TE.encodeUtf8Builder 103 104 instance ResponseData TL.Text where 105 response s h = 106 response s ((hContentType, "text/plain;charset=utf-8") : h) . TLE.encodeUtf8Builder 107 108 instance ResponseData JSON.Value where 109 response s h = 110 response s ((hContentType, "application/json") : h) . JSON.encode 111 112 instance ResponseData JSON.Encoding where 113 response s h = 114 response s ((hContentType, "application/json") : h) . JSON.fromEncoding 115 116 instance ResponseData JSON.Series where 117 response s h = 118 response s h . JSON.pairs 119 120 instance (JSON.ToJSON k, JSON.ToObject o, ResponseData o) => ResponseData (JSON.Record k o) where 121 response s h = 122 response s h . JSON.recordObject 123 124 instance ResponseData Html.Html where 125 response s h = 126 response s ((hContentType, "text/html;charset=utf-8") : h) . Html.renderHtmlBuilder 127 128 emptyResponse :: Status -> ResponseHeaders -> Response 129 emptyResponse s h = response s h BS.empty 130 131 okResponse :: ResponseData r => ResponseHeaders -> r -> Response 132 okResponse = response ok200 133 134 -- | A wrapper for the short-circuiting machinery (see 'result'). 135 newtype Result = Result { resultResponse :: Response } deriving (Typeable) 136 instance Show Result where 137 showsPrec p (Result r) = showParen (p > 10) 138 $ showString "Result " . showsPrec 11 (responseStatus r) 139 instance Exception Result 140 141 -- | Short circuit immediately, returning the given Reponse. 142 -- 143 -- FIXME: Rather than implementing this using exceptions, could we either use a 144 -- left-biased Alternative or simply use a better procedural style? 145 result :: MonadIO m => Response -> m a 146 result = liftIO . throwIO . Result 147 148 -- | Short circuit from within non-monadic code. Not recommended, and hardly 149 -- ever used. 150 unsafeResult :: Response -> a 151 unsafeResult = throw . Result 152 153 -- | Run some action that may short circut using 'result' or 'unsafeResult'. 154 runResult :: IO Response -> IO Response 155 runResult = handle (return . resultResponse) 156 157 proxyResponse :: HC.Response BSL.ByteString -> Response 158 proxyResponse r = responseLBS 159 (HC.responseStatus r) 160 (filter ((/= "transfer-encoding") . fst) $ HC.responseHeaders r) 161 (HC.responseBody r)