module Web.Respond.Types.Errors where
import Data.Aeson
import Data.Aeson.Encode (encodeToTextBuilder)
import qualified Data.Text as T
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString as BS
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import Data.Int (Int64)
import Formatting
import Control.Applicative ((<$>), (<*>), pure)
import Data.Monoid
import Data.Vector ()
import Data.Bool (bool)
import Network.HTTP.Types.Status
import Web.Respond.Types.Response
data ErrorReport = ErrorReport {
erReason :: T.Text,
erMessage :: Maybe T.Text,
erDetails :: Maybe Value
}
instance ToJSON ErrorReport where
toJSON er = object ["reason" .= erReason er, "message" .= erMessage er, "details" .= erDetails er]
simpleErrorReport :: T.Text -> ErrorReport
simpleErrorReport reason = ErrorReport reason Nothing Nothing
errorReportWithMessage :: T.Text -> T.Text -> ErrorReport
errorReportWithMessage reason message = ErrorReport reason (Just message) Nothing
errorReportWithDetails :: ToJSON d => T.Text -> d -> ErrorReport
errorReportWithDetails reason details = ErrorReport reason Nothing (Just $ toJSON details)
fullErrorReport :: ToJSON d => T.Text -> T.Text -> d -> ErrorReport
fullErrorReport reason message details = ErrorReport reason (Just message) (Just $ toJSON details)
single :: ToJSON a => T.Text -> Maybe a -> Value
single k = object . maybe mempty (pure . (k .=))
statusFormat :: Format Status
statusFormat = later (bprint (int % now " " % stext) <$> statusCode <*> T.decodeUtf8 . statusMessage)
maybeFormat :: forall m r a. m -> Holey TLB.Builder TLB.Builder (a -> m) -> Holey m r (Maybe a -> r)
maybeFormat x f = later (maybe x (bprint f))
errorReportFormat :: Format T.Text
-> Format T.Text
-> Format Value
-> Format ErrorReport
errorReportFormat reasonFmt messageFmt erdFmt = later (bprint (reasonFmt % maybeFormat "" messageFmt % maybeFormat "" erdFmt ) <$> erReason <*> erMessage <*> erDetails)
boolFormat :: Format Bool
boolFormat = later $ bprint . bool "false" "true"
mkIndent :: Int64 -> TLB.Builder
mkIndent = TLB.fromLazyText . flip TL.replicate " "
simpleJsonValue :: Format Value
simpleJsonValue = later encodeToTextBuilder
plaintextErrorReportFormat :: forall b. Holey TLB.Builder b (Status -> ErrorReport -> b)
plaintextErrorReportFormat = statusFormat % "---\n" % errorReportFormat ("reason: " % stext % "\n") ("message: " % stext % "\n") ("details: " % simpleJsonValue % "\n")
renderPlainTextErrorReport :: Status -> ErrorReport -> TL.Text
renderPlainTextErrorReport = format plaintextErrorReportFormat
pFormat :: Buildable a => Int64 -> Format a
pFormat indent = now (mkIndent indent) % "<p>" % build % "</p>\n"
htmlErrorReportFormat :: forall b. Holey TLB.Builder b (Status -> ErrorReport -> b)
htmlErrorReportFormat = "<!DOCTYPE html>\n" %
"<html>\n" %
" <head>\n" %
" <title>Error</title>\n" %
" </head>\n" %
" <body>\n" %
" <h1>" % statusFormat % "</h1>\n" %
errorReportFormat reasonFmt msgFmt detailsFmt %
" </body>\n" %
"</html>\n"
where
reasonFmt = pFormat 4 %. ("reason: " % stext)
msgFmt = pFormat 4 %. ("message: " % stext)
detailsFmt = pFormat 4 %. ("details: " % "<span>" % simpleJsonValue % "</span>")
renderHTMLErrorReport :: Status -> ErrorReport -> TL.Text
renderHTMLErrorReport = format htmlErrorReportFormat
class ReportableError e where
reportError :: Status
-> e
-> BS.ByteString
-> ResponseBody
instance ReportableError ErrorReport where
reportError status = matchToContentTypesDefault (textUtf8 "text/html" $ renderHTMLErrorReport status) [jsonMatcher, textUtf8 "text/plain" $ renderPlainTextErrorReport status]
reportAsErrorReport :: (a -> ErrorReport) -> Status -> a -> BS.ByteString -> ResponseBody
reportAsErrorReport f status = reportError status . f
instance ReportableError T.UnicodeException where
reportError = reportAsErrorReport report
where
report :: T.UnicodeException -> ErrorReport
report (T.DecodeError msg mInput) = fullErrorReport "unicode decode failed" (T.pack msg) (single "input" mInput)
report (T.EncodeError msg mInput) = fullErrorReport "unicode encode failed" (T.pack msg) (single "input" mInput)
newtype JsonParseError = JsonParseError { jsonParseErrorMsg :: String } deriving (Eq, Show)
instance ReportableError JsonParseError where
reportError = reportAsErrorReport $ errorReportWithMessage "parse_failed" . T.pack . jsonParseErrorMsg