wai-problem-details (empty) → 0.1.0.0
raw patch · 8 files changed
+349/−0 lines, 8 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, data-default, deriving-aeson, hspec, hspec-wai, hspec-wai-json, http-types, network-uri, text, wai, wai-problem-details
Files
- LICENSE +20/−0
- README.md +27/−0
- src/Network/Wai/Middleware/ProblemDetails.hs +58/−0
- src/Network/Wai/Middleware/ProblemDetails/Internal/Defaults.hs +46/−0
- src/Network/Wai/Middleware/ProblemDetails/Internal/Exception.hs +27/−0
- src/Network/Wai/Middleware/ProblemDetails/Internal/Types.hs +68/−0
- test/Spec.hs +40/−0
- wai-problem-details.cabal +63/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2023 Alexander Goussas++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,27 @@+# wai-problem-details++Middleware for returning problem details responses as specified in+https://www.rfc-editor.org/rfc/rfc7807.++```haskell+{-# LANGUAGE OverloadedStrings #-}++import qualified Web.Scotty as S+import Network.Wai.Handler.Warp (run)+import Data.Function ((&))+import Data.Default+import Network.Wai.Middleware.ProblemDetails++app :: IO Application+app = S.scottyApp $ do+ S.get "/default" $ throwProblemDetails def+ S.get "/predefined" $ throwProblemDetails problemDetails400+ S.get "/predefined-custom" $ throwProblemDetails (problemDetails404 & setTitle "Ahooy!")++main :: IO ()+main = run 8080 =<< app+```++## License++MIT
+ src/Network/Wai/Middleware/ProblemDetails.hs view
@@ -0,0 +1,58 @@+-- | Middleware for WAI that implements the problem details RFC specified in+-- https://www.rfc-editor.org/rfc/rfc7807.+--+-- Example:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > module Main where+-- >+-- > import Network.Wai.Handler.Warp (run)+-- > import Data.Default+-- > import Network.Wai.Middleware.ProblemDetails+-- >+-- > main :: IO ()+-- > main = run 8080 $ problemDetails $ app+-- > where+-- > app request respond = throwProblemDetails def+--+-- See the project's README and tests for more examples.+--+module Network.Wai.Middleware.ProblemDetails+(+ module Network.Wai.Middleware.ProblemDetails.Internal.Types+ , module Network.Wai.Middleware.ProblemDetails.Internal.Exception+ , module Network.Wai.Middleware.ProblemDetails.Internal.Defaults+ , problemDetails+)+where++import Network.Wai.Middleware.ProblemDetails.Internal.Defaults+import Network.Wai.Middleware.ProblemDetails.Internal.Exception+import Network.Wai.Middleware.ProblemDetails.Internal.Types++import Control.Exception (catch)+import Data.Aeson (encode)+import Data.ByteString+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Types (mkStatus)+import Network.Wai (Middleware,+ Response,+ responseLBS)+++-- | Middleware that sends a problem+json response when an exception of type+-- 'ProblemDetailsException' is thrown from a WAI application.+problemDetails :: Middleware+problemDetails app = \request respond -> app request respond `catch` (respond . catchProblemDetails)+ where+ catchProblemDetails :: ProblemDetailsException -> Response+ catchProblemDetails (ProblemDetailsException pd) = responseLBS+ (uncurry mkStatus $ getStatus pd)+ [("Content-Type", "application/problem+json")]+ (encode pd)++ getStatus :: ProblemDetails -> (Int, ByteString)+ getStatus pd = case (status pd, title pd) of+ (Just status', Just title') -> (status', encodeUtf8 title')+ _ -> (200, "Ok")
+ src/Network/Wai/Middleware/ProblemDetails/Internal/Defaults.hs view
@@ -0,0 +1,46 @@+module Network.Wai.Middleware.ProblemDetails.Internal.Defaults+(+ problemDetails400+ , problemDetails401+ , problemDetails403+ , problemDetails404+ , problemDetails409+)+where++import Network.Wai.Middleware.ProblemDetails.Internal.Types++import Data.Default+import Data.Function ((&))+import Data.Maybe (fromJust)+import Network.URI (parseURI)++problemDetails404 :: ProblemDetails+problemDetails404 = def+ & setStatus 404+ & setTitle "Not Found"+ & setType (fromJust $ parseURI "https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/404")++problemDetails400 :: ProblemDetails+problemDetails400 = def+ & setStatus 400+ & setTitle "Bad Request"+ & setType (fromJust $ parseURI "https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/400")++problemDetails401 :: ProblemDetails+problemDetails401 = def+ & setStatus 401+ & setTitle "Unauthorized"+ & setType (fromJust $ parseURI "https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/401")++problemDetails403 :: ProblemDetails+problemDetails403 = def+ & setStatus 403+ & setTitle "Forbidden"+ & setType (fromJust $ parseURI "https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/403")++problemDetails409 :: ProblemDetails+problemDetails409 = def+ & setStatus 409+ & setTitle "Conflict"+ & setType (fromJust $ parseURI "https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/409")
+ src/Network/Wai/Middleware/ProblemDetails/Internal/Exception.hs view
@@ -0,0 +1,27 @@+module Network.Wai.Middleware.ProblemDetails.Internal.Exception+(+ ProblemDetailsException (..)+ , throwProblemDetails+ , throwProblemDetailsIO+)+where++import Control.Exception (Exception,+ throw,+ throwIO)++import Network.Wai.Middleware.ProblemDetails.Internal.Types (ProblemDetails)++-- | The exception that can be thrown from WAI applications when using the problem details+-- middleware to send a problem details response.+newtype ProblemDetailsException = ProblemDetailsException ProblemDetails+ deriving stock Show+ deriving anyclass Exception++-- | Throw a 'ProblemDetailsException' from a pure context.+throwProblemDetails :: ProblemDetails -> a+throwProblemDetails = throw . ProblemDetailsException++-- | Throw a 'ProblemDetailsException' from an 'IO' context.+throwProblemDetailsIO :: ProblemDetails -> IO a+throwProblemDetailsIO = throwIO . ProblemDetailsException
+ src/Network/Wai/Middleware/ProblemDetails/Internal/Types.hs view
@@ -0,0 +1,68 @@+module Network.Wai.Middleware.ProblemDetails.Internal.Types+(+ ProblemDetails+ , setType+ , setTitle+ , title+ , setDetail+ , setInstance+ , setExtensions+ , setStatus+ , status+)+where++import Data.Aeson (Value)+import Data.Default+import Data.Text (Text)+import qualified Data.Text as T+import Deriving.Aeson+import Network.URI (URI)++-- | The problem details data type.+data ProblemDetails = ProblemDetails+ { pdType :: !(Maybe Text) -- ^ 'about:blank' when not present. This URI, when specified, should resolve to an HTML resource.+ , pdTitle :: !(Maybe Text)+ , pdStatus :: !(Maybe Int)+ , pdDetail :: !(Maybe Text)+ , pdInstance :: !(Maybe Text) -- ^ Identifies a specific occurrence of the problem.+ , pdExtensions :: !(Maybe Value)+ }+ deriving stock (Show, Generic)+ deriving (ToJSON)+ via CustomJSON '[OmitNothingFields, FieldLabelModifier '[StripPrefix "pd", CamelToSnake]] ProblemDetails++instance Default ProblemDetails where+ def = ProblemDetails Nothing Nothing Nothing Nothing Nothing Nothing++-- | 'status' return the status for this 'ProblemDetails'+status :: ProblemDetails -> Maybe Int+status = pdStatus++-- | 'setType' sets the type field of the problem details object.+setType :: URI -> ProblemDetails -> ProblemDetails+setType uri pd = pd {pdType = Just $ T.pack $ show uri}++-- | 'setStatus' sets the status field of the problem details object.+setStatus :: Int -> ProblemDetails -> ProblemDetails+setStatus status pd = pd {pdStatus = Just status}++-- | 'title' return the title for this 'ProblemDetails'+title :: ProblemDetails -> Maybe Text+title = pdTitle++-- | 'setTitle' sets the title field of the problem details object.+setTitle :: Text -> ProblemDetails -> ProblemDetails+setTitle title pd = pd {pdTitle = Just title}++-- | 'setDetail' sets the detail field of the problem details object.+setDetail :: Text -> ProblemDetails -> ProblemDetails+setDetail detail pd = pd {pdDetail = Just detail}++-- | 'setInstance' sets the instance field of the problem details object.+setInstance :: URI -> ProblemDetails -> ProblemDetails+setInstance inst pd = pd {pdInstance = Just $ T.pack $ show inst}++-- | 'setExtensions' adds the provided extensions to the problem details object.+setExtensions :: Value -> ProblemDetails -> ProblemDetails+setExtensions exts pd = pd {pdExtensions = Just exts}
+ test/Spec.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Main (main) where++import Data.Default+import Data.Function ((&))+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Middleware.ProblemDetails+import Test.Hspec+import Test.Hspec.Wai+import Test.Hspec.Wai.JSON++testApp :: IO Application+testApp = pure $ problemDetails $ \request respond ->+ case (pathInfo request, requestMethod request) of+ ([], "GET") -> respond $ responseLBS ok200 [] ""+ (["simple"], "GET") -> throwProblemDetails def+ (["custom"], "GET") -> throwProblemDetails (problemDetails404 & setTitle "Could not find user with that id.")++spec :: Spec+spec = with testApp $ do+ describe "GET /" $+ it "Responds with 200" $+ get "/" `shouldRespondWith` 200++ describe "GET /simple" $+ it "Responds with 200 and the correct Content-Type" $+ get "/simple" `shouldRespondWith` 200 {matchHeaders = ["Content-Type" <:> "application/problem+json"]}++ describe "GET /custom" $+ it "Responds with 404 and the correct JSON body" $+ get "/custom" `shouldRespondWith`+ [json|{"type":"https://developer.mozilla.org/en-US/docs/Web/HTTP/Status/404","title":"Could not find user with that id.","status":404}|]+ { matchStatus = 404+ , matchHeaders = ["Content-Type" <:> "application/problem+json"]+ }++main :: IO ()+main = hspec spec
+ wai-problem-details.cabal view
@@ -0,0 +1,63 @@+cabal-version: 2.4+name: wai-problem-details+version: 0.1.0.0+synopsis: Problem details middleware for WAI+description: + Problem details middleware for WAI.+ .+ It exposes a functions to throw exceptions of type+ ProblemDetailsException that implements the problem details+ RFC as specified in https://www.rfc-editor.org/rfc/rfc7807.+ .+homepage: https://github.com/aloussase/wai-problem-details+bug-reports: https://github.com/aloussase/wai-problem-details/issues+license: MIT+license-file: LICENSE+author: Alexander Goussas+maintainer: goussasalexander@gmail.com+copyright: Alexander Goussas 2023+category: Web+extra-source-files: README.md++source-repository head+ type: git+ location: https://github.com/aloussase/wai-problem-details.git++library+ ghc-options: -Wall+ exposed-modules: Network.Wai.Middleware.ProblemDetails+ other-modules: Network.Wai.Middleware.ProblemDetails.Internal.Types+ , Network.Wai.Middleware.ProblemDetails.Internal.Defaults+ , Network.Wai.Middleware.ProblemDetails.Internal.Exception+ build-depends: base ^>=4.16.4.0+ , aeson >= 2.1.2 && < 2.2+ , bytestring >= 0.11.3 && < 0.12+ , text >= 1.2.5 && < 1.3+ , data-default >= 0.7.1 && < 0.8+ , deriving-aeson >= 0.2.9 && < 0.3+ , http-types >= 0.12.3 && < 0.13+ , network-uri >= 2.6.4 && < 2.7+ , wai >= 3.2.3 && < 3.3+ hs-source-dirs: src+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ , DeriveGeneric+ , DeriveAnyClass+ , DerivingStrategies+ , DerivingVia+ , DataKinds+ , ScopedTypeVariables++test-suite wai-problem-details-test+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base ^>=4.16.4.0+ , wai-problem-details+ , http-types+ , wai+ , hspec+ , hspec-wai+ , data-default+ , hspec-wai-json