diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,27 @@ +Copyright (c) 2026 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,8 @@ +0.0.1.0 + +* Initial release +* Classy optics (Get/Has/Review/As) for Request, Response, FilePart, + RequestBodyLength +* Field lenses for Request and FilePart +* Constructor prisms for Response and RequestBodyLength +* Constructor classy optics for Response and RequestBodyLength diff --git a/src/Network/Wai/Optics.hs b/src/Network/Wai/Optics.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Optics.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wall #-} + +{- | Classy optics for the @wai@ package. + +This module re-exports all optics for @wai@ data types. +-} +module Network.Wai.Optics ( + module Network.Wai.Optics.Request, + module Network.Wai.Optics.Response, + module Network.Wai.Optics.FilePart, + module Network.Wai.Optics.RequestBodyLength, +) where + +import Network.Wai.Optics.FilePart +import Network.Wai.Optics.Request +import Network.Wai.Optics.RequestBodyLength +import Network.Wai.Optics.Response diff --git a/src/Network/Wai/Optics/FilePart.hs b/src/Network/Wai/Optics/FilePart.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Optics/FilePart.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Classy optics and field lenses for 'FilePart'. +module Network.Wai.Optics.FilePart ( + -- * Classy optics + GetFilePart (..), + HasFilePart (..), + ReviewFilePart (..), + AsFilePart (..), +) where + +import Control.Category (id) +import Control.Lens (Getter, Lens', Prism', Review, lens, prism', review, set, to, unto, view) +import Data.Maybe (Maybe (..)) +import Network.Wai.Internal (FilePart) +import qualified Network.Wai.Internal as Wai +import Network.Wai.Optics.Internal ( + filePartByteCountL, + filePartFileSizeL, + filePartOffsetL, + ) +import Prelude (Integer, const, flip, (.)) + +{- | Type class for values that can be viewed as a 'FilePart'. + +>>> view getFilePart (Wai.FilePart 0 100 200) +FilePart {filePartOffset = 0, filePartByteCount = 100, filePartFileSize = 200} + +>>> view getFilePartOffset (Wai.FilePart 10 100 200) +10 + +>>> view getFilePartByteCount (Wai.FilePart 0 100 200) +100 + +>>> view getFilePartFileSize (Wai.FilePart 0 100 200) +200 +-} +class GetFilePart s where + -- | A 'Getter' to obtain a 'FilePart'. + getFilePart :: Getter s FilePart + + -- | A 'Getter' on the byte offset of a 'FilePart'. + getFilePartOffset :: Getter s Integer + getFilePartOffset = getFilePart . to Wai.filePartOffset + {-# INLINE getFilePartOffset #-} + + -- | A 'Getter' on the byte count of a 'FilePart'. + getFilePartByteCount :: Getter s Integer + getFilePartByteCount = getFilePart . to Wai.filePartByteCount + {-# INLINE getFilePartByteCount #-} + + -- | A 'Getter' on the total file size of a 'FilePart'. + getFilePartFileSize :: Getter s Integer + getFilePartFileSize = getFilePart . to Wai.filePartFileSize + {-# INLINE getFilePartFileSize #-} + +instance GetFilePart FilePart where + getFilePart = id + {-# INLINE getFilePart #-} + getFilePartOffset = to Wai.filePartOffset + {-# INLINE getFilePartOffset #-} + getFilePartByteCount = to Wai.filePartByteCount + {-# INLINE getFilePartByteCount #-} + getFilePartFileSize = to Wai.filePartFileSize + {-# INLINE getFilePartFileSize #-} + +{- | Type class for values with a lens into a 'FilePart'. + +>>> view filePart (Wai.FilePart 0 100 200) +FilePart {filePartOffset = 0, filePartByteCount = 100, filePartFileSize = 200} + +>>> set filePart (Wai.FilePart 10 50 100) (Wai.FilePart 0 100 200) +FilePart {filePartOffset = 10, filePartByteCount = 50, filePartFileSize = 100} + +>>> view filePartOffset (Wai.FilePart 10 100 200) +10 + +>>> set filePartOffset 50 (Wai.FilePart 10 100 200) +FilePart {filePartOffset = 50, filePartByteCount = 100, filePartFileSize = 200} + +>>> view filePartByteCount (Wai.FilePart 0 100 200) +100 + +>>> set filePartByteCount 50 (Wai.FilePart 0 100 200) +FilePart {filePartOffset = 0, filePartByteCount = 50, filePartFileSize = 200} + +>>> view filePartFileSize (Wai.FilePart 0 100 200) +200 + +>>> set filePartFileSize 500 (Wai.FilePart 0 100 200) +FilePart {filePartOffset = 0, filePartByteCount = 100, filePartFileSize = 500} +-} +class (GetFilePart s) => HasFilePart s where + {-# MINIMAL setFilePart #-} + + -- | Replace the 'FilePart' component. + setFilePart :: FilePart -> s -> s + + -- | A 'Lens'' into the 'FilePart' component. + filePart :: Lens' s FilePart + filePart = lens (view getFilePart) (flip setFilePart) + {-# INLINE filePart #-} + + -- | Replace the byte offset of a 'FilePart'. + setFilePartOffset :: Integer -> s -> s + setFilePartOffset = set filePartOffset + {-# INLINE setFilePartOffset #-} + + -- | A 'Lens'' on the byte offset of a 'FilePart'. + filePartOffset :: Lens' s Integer + filePartOffset = filePart . filePartOffsetL + {-# INLINE filePartOffset #-} + + -- | Replace the byte count of a 'FilePart'. + setFilePartByteCount :: Integer -> s -> s + setFilePartByteCount = set filePartByteCount + {-# INLINE setFilePartByteCount #-} + + -- | A 'Lens'' on the byte count of a 'FilePart'. + filePartByteCount :: Lens' s Integer + filePartByteCount = filePart . filePartByteCountL + {-# INLINE filePartByteCount #-} + + -- | Replace the total file size of a 'FilePart'. + setFilePartFileSize :: Integer -> s -> s + setFilePartFileSize = set filePartFileSize + {-# INLINE setFilePartFileSize #-} + + -- | A 'Lens'' on the total file size of a 'FilePart'. + filePartFileSize :: Lens' s Integer + filePartFileSize = filePart . filePartFileSizeL + {-# INLINE filePartFileSize #-} + +instance HasFilePart FilePart where + setFilePart = const + {-# INLINE setFilePart #-} + filePartOffset = filePartOffsetL + {-# INLINE filePartOffset #-} + filePartByteCount = filePartByteCountL + {-# INLINE filePartByteCount #-} + filePartFileSize = filePartFileSizeL + {-# INLINE filePartFileSize #-} + +{- | Type class for values that can be constructed from a 'FilePart'. + +>>> review reviewFilePart (Wai.FilePart 0 100 200) :: FilePart +FilePart {filePartOffset = 0, filePartByteCount = 100, filePartFileSize = 200} +-} +class ReviewFilePart t where + -- | A 'Review' to construct a value from a 'FilePart'. + reviewFilePart :: Review t FilePart + +instance ReviewFilePart FilePart where + reviewFilePart = unto id + {-# INLINE reviewFilePart #-} + +{- | Type class for values with a prism into a 'FilePart'. + +>>> import Control.Lens (preview) +>>> preview _FilePart (Wai.FilePart 0 100 200) +Just (FilePart {filePartOffset = 0, filePartByteCount = 100, filePartFileSize = 200}) +-} +class (ReviewFilePart t) => AsFilePart t where + {-# MINIMAL matchFilePart #-} + + -- | Attempt to extract a 'FilePart'. + matchFilePart :: t -> Maybe FilePart + + -- | A 'Prism'' into a 'FilePart'. + _FilePart :: Prism' t FilePart + _FilePart = prism' (review reviewFilePart) matchFilePart + {-# INLINE _FilePart #-} + +instance AsFilePart FilePart where + matchFilePart = Just + {-# INLINE matchFilePart #-} diff --git a/src/Network/Wai/Optics/Internal.hs b/src/Network/Wai/Optics/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Optics/Internal.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall -Wno-deprecations #-} + +module Network.Wai.Optics.Internal ( + -- * Request field lenses + requestMethodL, + httpVersionL, + rawPathInfoL, + rawQueryStringL, + requestHeadersL, + isSecureL, + remoteHostL, + pathInfoL, + queryStringL, + requestBodyL, + vaultL, + requestBodyLengthL, + requestHeaderHostL, + requestHeaderRangeL, + requestHeaderRefererL, + requestHeaderUserAgentL, + + -- * FilePart field lenses + filePartOffsetL, + filePartByteCountL, + filePartFileSizeL, +) where + +import Control.Lens (Lens', lens) +import Data.Bool (Bool) +import Data.ByteString (ByteString) +import Data.Maybe (Maybe) +import Data.Text (Text) +import Data.Vault.Lazy (Vault) +import Network.HTTP.Types (HttpVersion, Method, Query, RequestHeaders) +import Network.Socket (SockAddr) +import Network.Wai.Internal ( + FilePart (..), + Request (..), + RequestBodyLength, + ) +import Prelude (IO, Integer) + +requestMethodL :: Lens' Request Method +requestMethodL = lens requestMethod (\r x -> r{requestMethod = x}) +{-# INLINE requestMethodL #-} + +httpVersionL :: Lens' Request HttpVersion +httpVersionL = lens httpVersion (\r x -> r{httpVersion = x}) +{-# INLINE httpVersionL #-} + +rawPathInfoL :: Lens' Request ByteString +rawPathInfoL = lens rawPathInfo (\r x -> r{rawPathInfo = x}) +{-# INLINE rawPathInfoL #-} + +rawQueryStringL :: Lens' Request ByteString +rawQueryStringL = lens rawQueryString (\r x -> r{rawQueryString = x}) +{-# INLINE rawQueryStringL #-} + +requestHeadersL :: Lens' Request RequestHeaders +requestHeadersL = lens requestHeaders (\r x -> r{requestHeaders = x}) +{-# INLINE requestHeadersL #-} + +isSecureL :: Lens' Request Bool +isSecureL = lens isSecure (\r x -> r{isSecure = x}) +{-# INLINE isSecureL #-} + +remoteHostL :: Lens' Request SockAddr +remoteHostL = lens remoteHost (\r x -> r{remoteHost = x}) +{-# INLINE remoteHostL #-} + +pathInfoL :: Lens' Request [Text] +pathInfoL = lens pathInfo (\r x -> r{pathInfo = x}) +{-# INLINE pathInfoL #-} + +queryStringL :: Lens' Request Query +queryStringL = lens queryString (\r x -> r{queryString = x}) +{-# INLINE queryStringL #-} + +requestBodyL :: Lens' Request (IO ByteString) +requestBodyL = lens requestBody (\r x -> r{requestBody = x}) +{-# INLINE requestBodyL #-} + +vaultL :: Lens' Request Vault +vaultL = lens vault (\r x -> r{vault = x}) +{-# INLINE vaultL #-} + +requestBodyLengthL :: Lens' Request RequestBodyLength +requestBodyLengthL = lens requestBodyLength (\r x -> r{requestBodyLength = x}) +{-# INLINE requestBodyLengthL #-} + +requestHeaderHostL :: Lens' Request (Maybe ByteString) +requestHeaderHostL = lens requestHeaderHost (\r x -> r{requestHeaderHost = x}) +{-# INLINE requestHeaderHostL #-} + +requestHeaderRangeL :: Lens' Request (Maybe ByteString) +requestHeaderRangeL = lens requestHeaderRange (\r x -> r{requestHeaderRange = x}) +{-# INLINE requestHeaderRangeL #-} + +requestHeaderRefererL :: Lens' Request (Maybe ByteString) +requestHeaderRefererL = lens requestHeaderReferer (\r x -> r{requestHeaderReferer = x}) +{-# INLINE requestHeaderRefererL #-} + +requestHeaderUserAgentL :: Lens' Request (Maybe ByteString) +requestHeaderUserAgentL = lens requestHeaderUserAgent (\r x -> r{requestHeaderUserAgent = x}) +{-# INLINE requestHeaderUserAgentL #-} + +filePartOffsetL :: Lens' FilePart Integer +filePartOffsetL = lens filePartOffset (\r x -> r{filePartOffset = x}) +{-# INLINE filePartOffsetL #-} + +filePartByteCountL :: Lens' FilePart Integer +filePartByteCountL = lens filePartByteCount (\r x -> r{filePartByteCount = x}) +{-# INLINE filePartByteCountL #-} + +filePartFileSizeL :: Lens' FilePart Integer +filePartFileSizeL = lens filePartFileSize (\r x -> r{filePartFileSize = x}) +{-# INLINE filePartFileSizeL #-} diff --git a/src/Network/Wai/Optics/Request.hs b/src/Network/Wai/Optics/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Optics/Request.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Classy optics and field lenses for 'Request'. +module Network.Wai.Optics.Request ( + -- * Classy optics + GetRequest (..), + HasRequest (..), + ReviewRequest (..), + AsRequest (..), +) where + +import Control.Category (id) +import Control.Lens (Getter, Lens', Prism', Review, lens, prism', review, set, to, unto, view) +import Data.Bool (Bool) +import Data.ByteString (ByteString) +import Data.Maybe (Maybe (..)) +import Data.Text (Text) +import Data.Vault.Lazy (Vault) +import Network.HTTP.Types (HttpVersion, Method, Query, RequestHeaders) +import Network.Socket (SockAddr) +import Network.Wai (Request) +import qualified Network.Wai as Wai +import Network.Wai.Internal (RequestBodyLength) +import Network.Wai.Optics.Internal ( + httpVersionL, + isSecureL, + pathInfoL, + queryStringL, + rawPathInfoL, + rawQueryStringL, + remoteHostL, + requestBodyL, + requestBodyLengthL, + requestHeaderHostL, + requestHeaderRangeL, + requestHeaderRefererL, + requestHeaderUserAgentL, + requestHeadersL, + requestMethodL, + vaultL, + ) +import Prelude (IO, const, flip, (.)) + +-- | Type class for values that can be viewed as a 'Request'. +class GetRequest s where + -- | A 'Getter' to obtain a 'Request'. + getRequest :: Getter s Request + + -- | A 'Getter' on the HTTP request method. + getRequestMethod :: Getter s Method + getRequestMethod = getRequest . to Wai.requestMethod + {-# INLINE getRequestMethod #-} + + -- | A 'Getter' on the HTTP version. + getHttpVersion :: Getter s HttpVersion + getHttpVersion = getRequest . to Wai.httpVersion + {-# INLINE getHttpVersion #-} + + -- | A 'Getter' on the raw path info. + getRawPathInfo :: Getter s ByteString + getRawPathInfo = getRequest . to Wai.rawPathInfo + {-# INLINE getRawPathInfo #-} + + -- | A 'Getter' on the raw query string. + getRawQueryString :: Getter s ByteString + getRawQueryString = getRequest . to Wai.rawQueryString + {-# INLINE getRawQueryString #-} + + -- | A 'Getter' on the request headers. + getRequestHeaders :: Getter s RequestHeaders + getRequestHeaders = getRequest . to Wai.requestHeaders + {-# INLINE getRequestHeaders #-} + + -- | A 'Getter' on whether the request was made over a secure connection. + getIsSecure :: Getter s Bool + getIsSecure = getRequest . to Wai.isSecure + {-# INLINE getIsSecure #-} + + -- | A 'Getter' on the remote host address. + getRemoteHost :: Getter s SockAddr + getRemoteHost = getRequest . to Wai.remoteHost + {-# INLINE getRemoteHost #-} + + -- | A 'Getter' on the parsed path segments. + getPathInfo :: Getter s [Text] + getPathInfo = getRequest . to Wai.pathInfo + {-# INLINE getPathInfo #-} + + -- | A 'Getter' on the parsed query string. + getQueryString :: Getter s Query + getQueryString = getRequest . to Wai.queryString + {-# INLINE getQueryString #-} + + -- | A 'Getter' on the request body action. + getRequestBody :: Getter s (IO ByteString) + getRequestBody = getRequest . to Wai.getRequestBodyChunk + {-# INLINE getRequestBody #-} + + -- | A 'Getter' on the 'Vault'. + getVault :: Getter s Vault + getVault = getRequest . to Wai.vault + {-# INLINE getVault #-} + + -- | A 'Getter' on the 'RequestBodyLength'. + getRequestBodyLengthField :: Getter s RequestBodyLength + getRequestBodyLengthField = getRequest . to Wai.requestBodyLength + {-# INLINE getRequestBodyLengthField #-} + + -- | A 'Getter' on the @Host@ header. + getRequestHeaderHost :: Getter s (Maybe ByteString) + getRequestHeaderHost = getRequest . to Wai.requestHeaderHost + {-# INLINE getRequestHeaderHost #-} + + -- | A 'Getter' on the @Range@ header. + getRequestHeaderRange :: Getter s (Maybe ByteString) + getRequestHeaderRange = getRequest . to Wai.requestHeaderRange + {-# INLINE getRequestHeaderRange #-} + + -- | A 'Getter' on the @Referer@ header. + getRequestHeaderReferer :: Getter s (Maybe ByteString) + getRequestHeaderReferer = getRequest . to Wai.requestHeaderReferer + {-# INLINE getRequestHeaderReferer #-} + + -- | A 'Getter' on the @User-Agent@ header. + getRequestHeaderUserAgent :: Getter s (Maybe ByteString) + getRequestHeaderUserAgent = getRequest . to Wai.requestHeaderUserAgent + {-# INLINE getRequestHeaderUserAgent #-} + +instance GetRequest Request where + getRequest = id + {-# INLINE getRequest #-} + getRequestMethod = to Wai.requestMethod + {-# INLINE getRequestMethod #-} + getHttpVersion = to Wai.httpVersion + {-# INLINE getHttpVersion #-} + getRawPathInfo = to Wai.rawPathInfo + {-# INLINE getRawPathInfo #-} + getRawQueryString = to Wai.rawQueryString + {-# INLINE getRawQueryString #-} + getRequestHeaders = to Wai.requestHeaders + {-# INLINE getRequestHeaders #-} + getIsSecure = to Wai.isSecure + {-# INLINE getIsSecure #-} + getRemoteHost = to Wai.remoteHost + {-# INLINE getRemoteHost #-} + getPathInfo = to Wai.pathInfo + {-# INLINE getPathInfo #-} + getQueryString = to Wai.queryString + {-# INLINE getQueryString #-} + getRequestBody = to Wai.getRequestBodyChunk + {-# INLINE getRequestBody #-} + getVault = to Wai.vault + {-# INLINE getVault #-} + getRequestBodyLengthField = to Wai.requestBodyLength + {-# INLINE getRequestBodyLengthField #-} + getRequestHeaderHost = to Wai.requestHeaderHost + {-# INLINE getRequestHeaderHost #-} + getRequestHeaderRange = to Wai.requestHeaderRange + {-# INLINE getRequestHeaderRange #-} + getRequestHeaderReferer = to Wai.requestHeaderReferer + {-# INLINE getRequestHeaderReferer #-} + getRequestHeaderUserAgent = to Wai.requestHeaderUserAgent + {-# INLINE getRequestHeaderUserAgent #-} + +-- | Type class for values with a lens into a 'Request'. +class (GetRequest s) => HasRequest s where + {-# MINIMAL setRequest #-} + + -- | Replace the 'Request' component. + setRequest :: Request -> s -> s + + -- | A 'Lens'' into the 'Request' component. + request :: Lens' s Request + request = lens (view getRequest) (flip setRequest) + {-# INLINE request #-} + + -- | Replace the HTTP request method. + setRequestMethod :: Method -> s -> s + setRequestMethod = set requestMethod + {-# INLINE setRequestMethod #-} + + -- | A 'Lens'' on the HTTP request method. + requestMethod :: Lens' s Method + requestMethod = request . requestMethodL + {-# INLINE requestMethod #-} + + -- | Replace the HTTP version. + setHttpVersion :: HttpVersion -> s -> s + setHttpVersion = set httpVersion + {-# INLINE setHttpVersion #-} + + -- | A 'Lens'' on the HTTP version. + httpVersion :: Lens' s HttpVersion + httpVersion = request . httpVersionL + {-# INLINE httpVersion #-} + + -- | Replace the raw path info. + setRawPathInfo :: ByteString -> s -> s + setRawPathInfo = set rawPathInfo + {-# INLINE setRawPathInfo #-} + + -- | A 'Lens'' on the raw path info. + rawPathInfo :: Lens' s ByteString + rawPathInfo = request . rawPathInfoL + {-# INLINE rawPathInfo #-} + + -- | Replace the raw query string. + setRawQueryString :: ByteString -> s -> s + setRawQueryString = set rawQueryString + {-# INLINE setRawQueryString #-} + + -- | A 'Lens'' on the raw query string. + rawQueryString :: Lens' s ByteString + rawQueryString = request . rawQueryStringL + {-# INLINE rawQueryString #-} + + -- | Replace the request headers. + setRequestHeaders :: RequestHeaders -> s -> s + setRequestHeaders = set requestHeaders + {-# INLINE setRequestHeaders #-} + + -- | A 'Lens'' on the request headers. + requestHeaders :: Lens' s RequestHeaders + requestHeaders = request . requestHeadersL + {-# INLINE requestHeaders #-} + + -- | Replace whether the request was made over a secure connection. + setIsSecure :: Bool -> s -> s + setIsSecure = set isSecure + {-# INLINE setIsSecure #-} + + -- | A 'Lens'' on whether the request was made over a secure connection. + isSecure :: Lens' s Bool + isSecure = request . isSecureL + {-# INLINE isSecure #-} + + -- | Replace the remote host address. + setRemoteHost :: SockAddr -> s -> s + setRemoteHost = set remoteHost + {-# INLINE setRemoteHost #-} + + -- | A 'Lens'' on the remote host address. + remoteHost :: Lens' s SockAddr + remoteHost = request . remoteHostL + {-# INLINE remoteHost #-} + + -- | Replace the parsed path segments. + setPathInfo :: [Text] -> s -> s + setPathInfo = set pathInfo + {-# INLINE setPathInfo #-} + + -- | A 'Lens'' on the parsed path segments. + pathInfo :: Lens' s [Text] + pathInfo = request . pathInfoL + {-# INLINE pathInfo #-} + + -- | Replace the parsed query string. + setQueryString :: Query -> s -> s + setQueryString = set queryString + {-# INLINE setQueryString #-} + + -- | A 'Lens'' on the parsed query string. + queryString :: Lens' s Query + queryString = request . queryStringL + {-# INLINE queryString #-} + + -- | Replace the request body action. + setRequestBody :: IO ByteString -> s -> s + setRequestBody = set requestBody + {-# INLINE setRequestBody #-} + + -- | A 'Lens'' on the request body action. + requestBody :: Lens' s (IO ByteString) + requestBody = request . requestBodyL + {-# INLINE requestBody #-} + + -- | Replace the 'Vault'. + setVault :: Vault -> s -> s + setVault = set vault + {-# INLINE setVault #-} + + -- | A 'Lens'' on the 'Vault'. + vault :: Lens' s Vault + vault = request . vaultL + {-# INLINE vault #-} + + -- | Replace the 'RequestBodyLength'. + setRequestBodyLengthField :: RequestBodyLength -> s -> s + setRequestBodyLengthField = set requestBodyLengthField + {-# INLINE setRequestBodyLengthField #-} + + -- | A 'Lens'' on the 'RequestBodyLength'. + requestBodyLengthField :: Lens' s RequestBodyLength + requestBodyLengthField = request . requestBodyLengthL + {-# INLINE requestBodyLengthField #-} + + -- | Replace the @Host@ header. + setRequestHeaderHost :: Maybe ByteString -> s -> s + setRequestHeaderHost = set requestHeaderHost + {-# INLINE setRequestHeaderHost #-} + + -- | A 'Lens'' on the @Host@ header. + requestHeaderHost :: Lens' s (Maybe ByteString) + requestHeaderHost = request . requestHeaderHostL + {-# INLINE requestHeaderHost #-} + + -- | Replace the @Range@ header. + setRequestHeaderRange :: Maybe ByteString -> s -> s + setRequestHeaderRange = set requestHeaderRange + {-# INLINE setRequestHeaderRange #-} + + -- | A 'Lens'' on the @Range@ header. + requestHeaderRange :: Lens' s (Maybe ByteString) + requestHeaderRange = request . requestHeaderRangeL + {-# INLINE requestHeaderRange #-} + + -- | Replace the @Referer@ header. + setRequestHeaderReferer :: Maybe ByteString -> s -> s + setRequestHeaderReferer = set requestHeaderReferer + {-# INLINE setRequestHeaderReferer #-} + + -- | A 'Lens'' on the @Referer@ header. + requestHeaderReferer :: Lens' s (Maybe ByteString) + requestHeaderReferer = request . requestHeaderRefererL + {-# INLINE requestHeaderReferer #-} + + -- | Replace the @User-Agent@ header. + setRequestHeaderUserAgent :: Maybe ByteString -> s -> s + setRequestHeaderUserAgent = set requestHeaderUserAgent + {-# INLINE setRequestHeaderUserAgent #-} + + -- | A 'Lens'' on the @User-Agent@ header. + requestHeaderUserAgent :: Lens' s (Maybe ByteString) + requestHeaderUserAgent = request . requestHeaderUserAgentL + {-# INLINE requestHeaderUserAgent #-} + +instance HasRequest Request where + setRequest = const + {-# INLINE setRequest #-} + requestMethod = requestMethodL + {-# INLINE requestMethod #-} + httpVersion = httpVersionL + {-# INLINE httpVersion #-} + rawPathInfo = rawPathInfoL + {-# INLINE rawPathInfo #-} + rawQueryString = rawQueryStringL + {-# INLINE rawQueryString #-} + requestHeaders = requestHeadersL + {-# INLINE requestHeaders #-} + isSecure = isSecureL + {-# INLINE isSecure #-} + remoteHost = remoteHostL + {-# INLINE remoteHost #-} + pathInfo = pathInfoL + {-# INLINE pathInfo #-} + queryString = queryStringL + {-# INLINE queryString #-} + requestBody = requestBodyL + {-# INLINE requestBody #-} + vault = vaultL + {-# INLINE vault #-} + requestBodyLengthField = requestBodyLengthL + {-# INLINE requestBodyLengthField #-} + requestHeaderHost = requestHeaderHostL + {-# INLINE requestHeaderHost #-} + requestHeaderRange = requestHeaderRangeL + {-# INLINE requestHeaderRange #-} + requestHeaderReferer = requestHeaderRefererL + {-# INLINE requestHeaderReferer #-} + requestHeaderUserAgent = requestHeaderUserAgentL + {-# INLINE requestHeaderUserAgent #-} + +-- | Type class for values that can be constructed from a 'Request'. +class ReviewRequest t where + -- | A 'Review' to construct a value from a 'Request'. + reviewRequest :: Review t Request + +instance ReviewRequest Request where + reviewRequest = unto id + {-# INLINE reviewRequest #-} + +-- | Type class for values with a prism into a 'Request'. +class (ReviewRequest t) => AsRequest t where + {-# MINIMAL matchRequest #-} + + -- | Attempt to extract a 'Request'. + matchRequest :: t -> Maybe Request + + -- | A 'Prism'' into a 'Request'. + _Request :: Prism' t Request + _Request = prism' (review reviewRequest) matchRequest + {-# INLINE _Request #-} + +instance AsRequest Request where + matchRequest = Just + {-# INLINE matchRequest #-} diff --git a/src/Network/Wai/Optics/RequestBodyLength.hs b/src/Network/Wai/Optics/RequestBodyLength.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Optics/RequestBodyLength.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Classy optics and constructor prisms for 'RequestBodyLength'. +module Network.Wai.Optics.RequestBodyLength ( + -- * Classy optics + GetRequestBodyLength (..), + HasRequestBodyLength (..), + ReviewRequestBodyLength (..), + AsRequestBodyLength (..), + + -- * Constructor prisms + + -- ** ChunkedBody + ReviewChunkedBody (..), + AsChunkedBody (..), + + -- ** KnownLength + ReviewKnownLength (..), + AsKnownLength (..), +) where + +import Control.Category (id) +import Control.Lens (Getter, Lens', Prism', Review, lens, prism', review, unto, view) +import Data.Maybe (Maybe (..)) +import Data.Word (Word64) +import Network.Wai.Internal (RequestBodyLength (..)) +import Prelude (const, flip) + +{- $setup +>>> import Control.Lens (view, set, preview) +>>> import Network.Wai.Internal (RequestBodyLength(ChunkedBody, KnownLength)) +-} + +{- | Type class for values that can be viewed as a 'RequestBodyLength'. + +>>> view getRequestBodyLength ChunkedBody +ChunkedBody + +>>> view getRequestBodyLength (KnownLength 1024) +KnownLength 1024 +-} +class GetRequestBodyLength s where + -- | A 'Getter' to obtain a 'RequestBodyLength'. + getRequestBodyLength :: Getter s RequestBodyLength + +instance GetRequestBodyLength RequestBodyLength where + getRequestBodyLength = id + {-# INLINE getRequestBodyLength #-} + +{- | Type class for values with a lens into a 'RequestBodyLength'. + +>>> set requestBodyLengthL (KnownLength 512) ChunkedBody +KnownLength 512 +-} +class (GetRequestBodyLength s) => HasRequestBodyLength s where + {-# MINIMAL setRequestBodyLength #-} + + -- | Replace the 'RequestBodyLength' component. + setRequestBodyLength :: RequestBodyLength -> s -> s + + -- | A 'Lens'' into the 'RequestBodyLength' component. + requestBodyLengthL :: Lens' s RequestBodyLength + requestBodyLengthL = lens (view getRequestBodyLength) (flip setRequestBodyLength) + {-# INLINE requestBodyLengthL #-} + +instance HasRequestBodyLength RequestBodyLength where + setRequestBodyLength = const + {-# INLINE setRequestBodyLength #-} + +{- | Type class for values that can be constructed from a 'RequestBodyLength'. + +>>> review reviewRequestBodyLength ChunkedBody :: RequestBodyLength +ChunkedBody +-} +class ReviewRequestBodyLength t where + -- | A 'Review' to construct a value from a 'RequestBodyLength'. + reviewRequestBodyLength :: Review t RequestBodyLength + +instance ReviewRequestBodyLength RequestBodyLength where + reviewRequestBodyLength = unto id + {-# INLINE reviewRequestBodyLength #-} + +{- | Type class for values with a prism into a 'RequestBodyLength'. + +>>> preview _RequestBodyLength (KnownLength 1024) +Just (KnownLength 1024) +-} +class (ReviewRequestBodyLength t) => AsRequestBodyLength t where + {-# MINIMAL matchRequestBodyLength #-} + + -- | Attempt to extract a 'RequestBodyLength'. + matchRequestBodyLength :: t -> Maybe RequestBodyLength + + -- | A 'Prism'' into a 'RequestBodyLength'. + _RequestBodyLength :: Prism' t RequestBodyLength + _RequestBodyLength = prism' (review reviewRequestBodyLength) matchRequestBodyLength + {-# INLINE _RequestBodyLength #-} + +instance AsRequestBodyLength RequestBodyLength where + matchRequestBodyLength = Just + {-# INLINE matchRequestBodyLength #-} + +-- ** ChunkedBody + +{- | Type class for values that can be constructed as a 'ChunkedBody'. + +>>> review reviewChunkedBody () :: RequestBodyLength +ChunkedBody +-} +class ReviewChunkedBody t where + -- | A 'Review' to construct a 'ChunkedBody'. + reviewChunkedBody :: Review t () + +instance ReviewChunkedBody RequestBodyLength where + reviewChunkedBody = unto (\() -> ChunkedBody) + {-# INLINE reviewChunkedBody #-} + +{- | Type class for values with a prism into a 'ChunkedBody'. + +>>> preview _ChunkedBody ChunkedBody +Just () + +>>> preview _ChunkedBody (KnownLength 1024) +Nothing +-} +class (ReviewChunkedBody t) => AsChunkedBody t where + {-# MINIMAL matchChunkedBody #-} + + -- | Attempt to match a 'ChunkedBody'. + matchChunkedBody :: t -> Maybe () + + -- | A 'Prism'' into a 'ChunkedBody'. + _ChunkedBody :: Prism' t () + _ChunkedBody = prism' (review reviewChunkedBody) matchChunkedBody + {-# INLINE _ChunkedBody #-} + +instance AsChunkedBody RequestBodyLength where + matchChunkedBody = \case + ChunkedBody -> Just () + _ -> Nothing + {-# INLINE matchChunkedBody #-} + +-- ** KnownLength + +{- | Type class for values that can be constructed as a 'KnownLength'. + +>>> review reviewKnownLength 1024 :: RequestBodyLength +KnownLength 1024 +-} +class ReviewKnownLength t where + -- | A 'Review' to construct a 'KnownLength'. + reviewKnownLength :: Review t Word64 + +instance ReviewKnownLength RequestBodyLength where + reviewKnownLength = unto KnownLength + {-# INLINE reviewKnownLength #-} + +{- | Type class for values with a prism into a 'KnownLength'. + +>>> preview _KnownLength (KnownLength 1024) +Just 1024 + +>>> preview _KnownLength ChunkedBody +Nothing +-} +class (ReviewKnownLength t) => AsKnownLength t where + {-# MINIMAL matchKnownLength #-} + + -- | Attempt to extract the length from a 'KnownLength'. + matchKnownLength :: t -> Maybe Word64 + + -- | A 'Prism'' into a 'KnownLength'. + _KnownLength :: Prism' t Word64 + _KnownLength = prism' (review reviewKnownLength) matchKnownLength + {-# INLINE _KnownLength #-} + +instance AsKnownLength RequestBodyLength where + matchKnownLength = \case + KnownLength n -> Just n + _ -> Nothing + {-# INLINE matchKnownLength #-} diff --git a/src/Network/Wai/Optics/Response.hs b/src/Network/Wai/Optics/Response.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Optics/Response.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Classy optics and constructor prisms for 'Response'. +module Network.Wai.Optics.Response ( + -- * Classy optics + GetResponse (..), + HasResponse (..), + ReviewResponse (..), + AsResponse (..), + + -- * Constructor prisms + + -- ** ResponseFile + ReviewResponseFile (..), + AsResponseFile (..), + + -- ** ResponseBuilder + ReviewResponseBuilder (..), + AsResponseBuilder (..), + + -- ** ResponseStream + ReviewResponseStream (..), + AsResponseStream (..), + + -- ** ResponseRaw + ReviewResponseRaw (..), + AsResponseRaw (..), + + -- * Getters + responseStatus, + responseHeaders, +) where + +import Control.Category (id) +import Control.Lens (Getter, Lens', Prism', Review, lens, prism', review, to, unto, view) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (Builder) +import Data.Maybe (Maybe (..)) +import Network.HTTP.Types (ResponseHeaders, Status) +import Network.Wai (Response, StreamingBody) +import qualified Network.Wai as Wai +import Network.Wai.Internal ( + FilePart, + Response (..), + ) +import Prelude (FilePath, IO, const, flip, uncurry) + +-- | Type class for values that can be viewed as a 'Response'. +class GetResponse s where + -- | A 'Getter' to obtain a 'Response'. + getResponse :: Getter s Response + +instance GetResponse Response where + getResponse = id + {-# INLINE getResponse #-} + +-- | Type class for values with a lens into a 'Response'. +class (GetResponse s) => HasResponse s where + {-# MINIMAL setResponse #-} + + -- | Replace the 'Response' component. + setResponse :: Response -> s -> s + + -- | A 'Lens'' into the 'Response' component. + response :: Lens' s Response + response = lens (view getResponse) (flip setResponse) + {-# INLINE response #-} + +instance HasResponse Response where + setResponse = const + {-# INLINE setResponse #-} + +-- | Type class for values that can be constructed from a 'Response'. +class ReviewResponse t where + -- | A 'Review' to construct a value from a 'Response'. + reviewResponse :: Review t Response + +instance ReviewResponse Response where + reviewResponse = unto id + {-# INLINE reviewResponse #-} + +-- | Type class for values with a prism into a 'Response'. +class (ReviewResponse t) => AsResponse t where + {-# MINIMAL matchResponse #-} + + -- | Attempt to extract a 'Response'. + matchResponse :: t -> Maybe Response + + -- | A 'Prism'' into a 'Response'. + _Response :: Prism' t Response + _Response = prism' (review reviewResponse) matchResponse + {-# INLINE _Response #-} + +instance AsResponse Response where + matchResponse = Just + {-# INLINE matchResponse #-} + +-- | A 'Getter' on the 'Status' of a 'Response'. +responseStatus :: Getter Response Status +responseStatus = to Wai.responseStatus +{-# INLINE responseStatus #-} + +-- | A 'Getter' on the 'ResponseHeaders' of a 'Response'. +responseHeaders :: Getter Response ResponseHeaders +responseHeaders = to Wai.responseHeaders +{-# INLINE responseHeaders #-} + +-- ** ResponseFile + +-- | Type class for values that can be constructed from a @ResponseFile@. +class ReviewResponseFile t where + -- | A 'Review' to construct a value from @ResponseFile@ components. + reviewResponseFile :: Review t (Status, ResponseHeaders, FilePath, Maybe FilePart) + +instance ReviewResponseFile Response where + reviewResponseFile = unto (\(s, h, fp, mfp) -> ResponseFile s h fp mfp) + {-# INLINE reviewResponseFile #-} + +-- | Type class for values with a prism into a @ResponseFile@. +class (ReviewResponseFile t) => AsResponseFile t where + {-# MINIMAL matchResponseFile #-} + + -- | Attempt to extract @ResponseFile@ components. + matchResponseFile :: t -> Maybe (Status, ResponseHeaders, FilePath, Maybe FilePart) + + -- | A 'Prism'' into @ResponseFile@ components. + _ResponseFile :: Prism' t (Status, ResponseHeaders, FilePath, Maybe FilePart) + _ResponseFile = prism' (review reviewResponseFile) matchResponseFile + {-# INLINE _ResponseFile #-} + +instance AsResponseFile Response where + matchResponseFile = \case + ResponseFile s h fp mfp -> Just (s, h, fp, mfp) + _ -> Nothing + {-# INLINE matchResponseFile #-} + +-- ** ResponseBuilder + +-- | Type class for values that can be constructed from a @ResponseBuilder@. +class ReviewResponseBuilder t where + -- | A 'Review' to construct a value from @ResponseBuilder@ components. + reviewResponseBuilder :: Review t (Status, ResponseHeaders, Builder) + +instance ReviewResponseBuilder Response where + reviewResponseBuilder = unto (\(s, h, b) -> ResponseBuilder s h b) + {-# INLINE reviewResponseBuilder #-} + +-- | Type class for values with a prism into a @ResponseBuilder@. +class (ReviewResponseBuilder t) => AsResponseBuilder t where + {-# MINIMAL matchResponseBuilder #-} + + -- | Attempt to extract @ResponseBuilder@ components. + matchResponseBuilder :: t -> Maybe (Status, ResponseHeaders, Builder) + + -- | A 'Prism'' into @ResponseBuilder@ components. + _ResponseBuilder :: Prism' t (Status, ResponseHeaders, Builder) + _ResponseBuilder = prism' (review reviewResponseBuilder) matchResponseBuilder + {-# INLINE _ResponseBuilder #-} + +instance AsResponseBuilder Response where + matchResponseBuilder = \case + ResponseBuilder s h b -> Just (s, h, b) + _ -> Nothing + {-# INLINE matchResponseBuilder #-} + +-- ** ResponseStream + +-- | Type class for values that can be constructed from a @ResponseStream@. +class ReviewResponseStream t where + -- | A 'Review' to construct a value from @ResponseStream@ components. + reviewResponseStream :: Review t (Status, ResponseHeaders, StreamingBody) + +instance ReviewResponseStream Response where + reviewResponseStream = unto (\(s, h, sb) -> ResponseStream s h sb) + {-# INLINE reviewResponseStream #-} + +-- | Type class for values with a prism into a @ResponseStream@. +class (ReviewResponseStream t) => AsResponseStream t where + {-# MINIMAL matchResponseStream #-} + + -- | Attempt to extract @ResponseStream@ components. + matchResponseStream :: t -> Maybe (Status, ResponseHeaders, StreamingBody) + + -- | A 'Prism'' into @ResponseStream@ components. + _ResponseStream :: Prism' t (Status, ResponseHeaders, StreamingBody) + _ResponseStream = prism' (review reviewResponseStream) matchResponseStream + {-# INLINE _ResponseStream #-} + +instance AsResponseStream Response where + matchResponseStream = \case + ResponseStream s h sb -> Just (s, h, sb) + _ -> Nothing + {-# INLINE matchResponseStream #-} + +-- ** ResponseRaw + +-- | Type class for values that can be constructed from a @ResponseRaw@. +class ReviewResponseRaw t where + -- | A 'Review' to construct a value from @ResponseRaw@ components. + reviewResponseRaw :: Review t (IO ByteString -> (ByteString -> IO ()) -> IO (), Response) + +instance ReviewResponseRaw Response where + reviewResponseRaw = unto (uncurry ResponseRaw) + {-# INLINE reviewResponseRaw #-} + +-- | Type class for values with a prism into a @ResponseRaw@. +class (ReviewResponseRaw t) => AsResponseRaw t where + {-# MINIMAL matchResponseRaw #-} + + -- | Attempt to extract @ResponseRaw@ components. + matchResponseRaw :: t -> Maybe (IO ByteString -> (ByteString -> IO ()) -> IO (), Response) + + -- | A 'Prism'' into @ResponseRaw@ components. + _ResponseRaw :: Prism' t (IO ByteString -> (ByteString -> IO ()) -> IO (), Response) + _ResponseRaw = prism' (review reviewResponseRaw) matchResponseRaw + {-# INLINE _ResponseRaw #-} + +instance AsResponseRaw Response where + matchResponseRaw = \case + ResponseRaw f r -> Just (f, r) + _ -> Nothing + {-# INLINE matchResponseRaw #-} diff --git a/test/doctest_tests.hs b/test/doctest_tests.hs new file mode 100644 --- /dev/null +++ b/test/doctest_tests.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -Wall #-} + +module Main where + +import System.Exit (ExitCode (ExitFailure, ExitSuccess), exitFailure, exitSuccess) +import System.Process (rawSystem) + +main :: IO () +main = do + r <- + rawSystem + "cabal" + [ "exec" + , "--" + , "doctest" + , "-isrc" + , "src/Network/Wai/Optics/FilePart.hs" + , "src/Network/Wai/Optics/RequestBodyLength.hs" + ] + case r of + ExitSuccess -> exitSuccess + ExitFailure _ -> exitFailure diff --git a/waiz.cabal b/waiz.cabal new file mode 100644 --- /dev/null +++ b/waiz.cabal @@ -0,0 +1,87 @@ +name: waiz +version: 0.0.1.0 +license: BSD3 +license-file: LICENCE +author: Tony Morris +maintainer: Tony Morris +copyright: Copyright (c) 2026 Tony Morris +synopsis: Classy optics for the wai package +category: Web +description: + Classy optics (@GetXXX@, @HasXXX@, @ReviewXXX@, @AsXXX@) for all + data types in the + package. + . + For each data type in @wai@ (@Request@, @Response@, @FilePart@, + @RequestBodyLength@), this package provides: + . + * Getter type class (@GetXXX@) + * Lens type class (@HasXXX@) + * Review type class (@ReviewXXX@) + * Prism type class (@AsXXX@) + . + For record types, individual field lenses are provided. + For sum types, constructor prisms with their own classy optics are provided. + +homepage: https://gitlab.com/tonymorris/waiz +bug-reports: https://gitlab.com/tonymorris/waiz/-/issues +cabal-version: >= 1.10 +build-type: Simple +extra-source-files: changelog +tested-with: GHC == 9.6.7 + +source-repository head + type: git + location: git@gitlab.com:tonymorris/waiz.git + +library + default-language: + Haskell2010 + + build-depends: + base >= 4.18 && < 5 + , bytestring >= 0.11 && < 1 + , http-types >= 0.12 && < 1 + , lens >= 4.20 && < 6 + , network >= 3.1 && < 4 + , text >= 2.0 && < 3 + , vault >= 0.3 && < 1 + , wai >= 3.2 && < 4 + + ghc-options: + -Wall + + hs-source-dirs: + src + + exposed-modules: + Network.Wai.Optics + Network.Wai.Optics.FilePart + Network.Wai.Optics.Request + Network.Wai.Optics.RequestBodyLength + Network.Wai.Optics.Response + + other-modules: + Network.Wai.Optics.Internal + +test-suite doctest + type: + exitcode-stdio-1.0 + + main-is: + doctest_tests.hs + + default-language: + Haskell2010 + + build-depends: + base >= 4.18 && < 5 + , process >= 1.6 && < 2 + , waiz + + ghc-options: + -Wall + -threaded + + hs-source-dirs: + test