diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,9 @@ +# Changelog + +## 0.6.0.2 + +- Relax upper bounds on `containers` and `time`. + +## 0.6.0.1 + +- Support GHC 9.14. diff --git a/om-http.cabal b/om-http.cabal --- a/om-http.cabal +++ b/om-http.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: om-http -version: 0.3.1.1 +version: 0.6.0.2 synopsis: Http utilities. description: Random HTTP utilities. homepage: https://github.com/owensmurray/om-http @@ -8,34 +8,39 @@ license-file: LICENSE author: Rick Owens maintainer: rick@owensmurray.com -copyright: 2022 Owens Murray +copyright: 2025 Owens Murray category: Web build-type: Simple extra-source-files: README.md LICENSE + changelog.md common dependencies build-depends: - , async >= 2.2.4 && < 2.3 - , base >= 4.15.1.0 && < 4.21 - , bytestring >= 0.10.12.1 && < 0.13 - , directory >= 1.3.6.2 && < 1.4 - , filepath >= 1.4.2.1 && < 1.6 - , http-types >= 0.12.3 && < 0.13 - , mime-types >= 0.1.1.0 && < 0.2 - , monad-logger >= 0.3.37 && < 0.4 - , network >= 3.1.2.7 && < 3.3 - , om-show >= 0.1.2.6 && < 0.2 - , safe-exceptions >= 0.1.7.3 && < 0.2 - , servant >= 0.19 && < 0.21 - , template-haskell >= 2.17.0.0 && < 2.23 - , text >= 1.2.5.0 && < 2.2 - , time >= 1.9.3 && < 1.13 - , unix >= 2.7.2.2 && < 2.9 - , uuid >= 1.3.15 && < 1.4 - , wai >= 3.2.3 && < 3.3 - , warp >= 3.3.23 && < 3.5 + , aeson >= 2.2.2.0 && < 2.3 + , async >= 2.2.5 && < 2.3 + , base >= 4.20.0.0 && < 4.23 + , base64 >= 1.0 && < 1.1 + , bytestring >= 0.11.5.0 && < 0.13 + , case-insensitive >= 1.2.0.11 && < 1.3 + , containers >= 0.6.8 && < 0.9 + , directory >= 1.3.7.1 && < 1.4 + , filepath >= 1.4.101.0 && < 1.6 + , http-types >= 0.12.4 && < 0.13 + , mime-types >= 0.1.0.0 && < 0.2 + , monad-logger-aeson >= 0.4.1.2 && < 0.5 + , network >= 3.1.2.9 && < 3.3 + , om-show >= 0.1.2.10 && < 0.2 + , safe-exceptions >= 0.1.7.4 && < 0.2 + , servant >= 0.20.1 && < 0.21 + , template-haskell >= 2.22.0.0 && < 2.25 + , text >= 2.1.1 && < 2.2 + , time >= 1.9.2 && < 1.16 + , unix >= 2.7.3 && < 2.9 + , uuid >= 1.3.16 && < 1.4 + , wai >= 3.2.0 && < 3.3 + , warp >= 3.3.21 && < 3.5 common warnings ghc-options: diff --git a/src/OM/HTTP.hs b/src/OM/HTTP.hs --- a/src/OM/HTTP.hs +++ b/src/OM/HTTP.hs @@ -1,7 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-redundant-constraints #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {- | Miscellaneous HTTP Utilities. -} module OM.HTTP ( @@ -23,43 +22,62 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_) -import Control.Exception.Safe (SomeException, bracket, finally, throwM, - tryAny) +import Control.Exception (someExceptionContext, try) +import Control.Exception.Context (displayExceptionContext) +import Control.Exception.Safe (SomeException, bracket, finally, throwM, tryAny) import Control.Monad (join, void) import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Logger (LoggingT(runLoggingT), Loc, LogLevel, - LogSource, LogStr, MonadLoggerIO, logError, logInfo) +import Control.Monad.Logger.Aeson + ( LoggingT(runLoggingT), Message((:#)), (.=), Loc, LogLevel, LogSource, LogStr + , MonadLoggerIO, logError, logInfo + ) +import Data.Aeson (object) +import Data.Base64.Types (extractBase64) import Data.ByteString (ByteString) +import Data.ByteString.Base64 (encodeBase64) import Data.List ((\\)) import Data.Maybe (catMaybes) +import Data.Set (Set, member) import Data.String (IsString(fromString)) import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8) +import Data.Text.Encoding (decodeUtf8') import Data.Time (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) import Data.UUID (UUID) import Data.UUID.V1 (nextUUID) import Data.Version (Version, showVersion) import Language.Haskell.TH (Code(examineCode), Q, TExp, runIO) import Language.Haskell.TH.Syntax (addDependentFile) -import Network.HTTP.Types (Status(statusCode, statusMessage), Header, - internalServerError500, methodNotAllowed405, movedPermanently301, - ok200, status404) +import Network.HTTP.Types + ( Status(statusCode, statusMessage), Header, HeaderName + , internalServerError500, methodNotAllowed405, movedPermanently301, ok200 + , status404 + ) import Network.Mime (defaultMimeLookup) -import Network.Socket (AddrInfo(addrAddress), Family(AF_INET), - SocketType(Stream), Socket, close, connect, defaultProtocol, - getAddrInfo, socket) +import Network.Socket + ( AddrInfo(addrAddress), Family(AF_INET), SocketType(Stream), Socket, close + , connect, defaultProtocol, getAddrInfo, socket + ) import Network.Socket.ByteString (recv, sendAll) -import Network.Wai (Request(pathInfo, rawPathInfo, rawQueryString, - requestMethod), Application, Middleware, Response, ResponseReceived, - mapResponseHeaders, responseLBS, responseRaw, responseStatus) -import Network.Wai.Handler.Warp (run) +import Network.Wai + ( Request + ( isSecure, pathInfo, rawPathInfo, rawQueryString, remoteHost + , requestHeaders, requestMethod + ) + , Application, Middleware, Response, ResponseReceived, mapResponseHeaders + , responseHeaders, responseLBS, responseRaw, responseStatus + ) +import Network.Wai.Handler.Warp + ( HostPreference, Settings, defaultSettings, runSettings, setHost, setPort + ) import OM.Show (showt) -import Prelude (Either(Left, Right), Eq((/=), (==)), Foldable(elem, - foldr), Functor(fmap), Maybe(Just, Nothing), Monad((>>), (>>=), return), - MonadFail(fail), Monoid(mempty), RealFrac(truncate), Semigroup((<>)), - Show(show), Traversable(mapM), ($), (++), (.), (<$>), (=<<), FilePath, - IO, Int, String, concat, drop, filter, fst, id, mapM_, otherwise, - putStrLn, zip) +import Prelude + ( Applicative(pure), Either(Left, Right), Eq((/=), (==)) + , Foldable(elem, foldr), Functor(fmap), Maybe(Just, Nothing) + , Monad((>>), (>>=), return), MonadFail(fail), Monoid(mempty) + , RealFrac(truncate), Semigroup((<>)), Show(show), Traversable(mapM), ($) + , (++), (.), (<$>), (=<<), FilePath, IO, Int, String, concat, drop, filter + , fst, id, mapM_, otherwise, putStrLn, seq, zip + ) import Servant.API (ToHttpApiData(toUrlPiece)) import System.Directory (getDirectoryContents) import System.FilePath.Posix ((), combine) @@ -68,6 +86,7 @@ import qualified Data.ByteString.Char8 as BS8 import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 +import qualified Data.CaseInsensitive as CI import qualified Data.Text as T @@ -78,17 +97,24 @@ -} runTlsRedirect :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) {- ^ Logging backend. -} + -> HostPreference -> ByteString {- ^ Server name. -} -> Version {- ^ Server version. -} -> ByteString {- ^ Target URL. -} -> IO () -runTlsRedirect logging serverName serverVersion url = - run 80 - . requestLogging logging - . setServer serverName serverVersion - . hstsDirective 600 - . logExceptionsAndContinue logging - $ tlsRedirect url +runTlsRedirect logging host serverName serverVersion url = + runSettings settings + . requestLogging logging mempty + . setServer serverName serverVersion + . hstsDirective 600 + . logExceptionsAndContinue logging + $ tlsRedirect url + where + settings :: Settings + settings = + setPort 80 + . setHost host + $ defaultSettings {- | @@ -165,37 +191,85 @@ logs that the request has begun. The second messages logs the status result and timing of the request once it is finished. - > Starting request: GET /foo - > GET /foo --> 200 Ok (0.001s) + > {"text":"Starting request: GET /api/me","meta":{....}} + > {"text":"Request complete: GET /api/me","meta":{"status":"200 OK","time":"0.000370671s"}} This can help debugging requests that hang or crash for whatever reason. -} requestLogging :: (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) + -> Set HeaderName {-^ Headers to redact -} -> Middleware -requestLogging logging app req respond = +requestLogging logging redactHeaders app req respond = (`runLoggingT` logging) $ do - $(logInfo) $ "Starting request: " <> reqStr - liftIO . app req . loggingRespond =<< liftIO getCurrentTime + logInfo $ "Starting request: " <> reqStr :# + [ "method" .= decodeUtf8Safe (requestMethod req) + , "path" .= decodeUtf8Safe (rawPathInfo req) + , "query" .= decodeUtf8Safe (rawQueryString req) + , "secure" .= isSecure req + , "remote_host" .= show (remoteHost req) + , "headers" .= + fmap + (\(name, val) -> + decodeUtf8Safe (CI.original name) + <> ": " + <> if name `member` redactHeaders + then "" + else decodeUtf8Safe val + ) + (requestHeaders req) + ] + now <- liftIO getCurrentTime + liftIO (try (app req (loggingRespond now))) >>= \case + Left err -> do + logError $ + "`app` failed with exception. The exception will be re-thrown." :# + [ "exception" .= show (err :: SomeException) + , "context" .= displayExceptionContext (someExceptionContext err) + ] + throwM err + Right val -> pure val where {- | Delegate to the underlying responder, and do some logging. -} loggingRespond :: UTCTime -> Response -> IO ResponseReceived - loggingRespond start response = (`runLoggingT` logging) $ do - {- - Execute the underlying responder first so we get an accurate - measurement of the request duration. - -} - ack <- liftIO $ respond response - now <- liftIO getCurrentTime - $(logInfo) - $ reqStr <> " --> " <> showStatus (responseStatus response) - <> " (" <> showt (diffUTCTime now start) <> ")" - return ack + loggingRespond start response = + (`runLoggingT` logging) $ do + {- + Execute the underlying responder first so we get an accurate + measurement of the request duration. + -} + ack <- liftIO (try (respond response)) >>= \case + Left err -> do + logError $ + "`respond` failed with exception. The exception will be re-thrown." :# + [ "exception" .= show (err :: SomeException) + , "context" .= displayExceptionContext (someExceptionContext err) + , "response" .= object + [ "status" .= showStatus (responseStatus response) + , "headers" .= + fmap + (\(name, val) -> + decodeUtf8Safe (CI.original name) + <> ": " + <> decodeUtf8Safe val + ) + (responseHeaders response) + ] + ] + throwM err + Right ack -> pure ack + now <- ack `seq` liftIO getCurrentTime + logInfo $ "Request complete: " <> reqStr :# + [ "status" .= showStatus (responseStatus response) + , "time" .= show (diffUTCTime now start) + ] + return ack {- | A Text representation of the request, suitable for logging. -} reqStr :: Text - reqStr = decodeUtf8 - $ requestMethod req <> " " <> rawPathInfo req <> rawQueryString req + reqStr = + decodeUtf8Safe + (requestMethod req <> " " <> rawPathInfo req <> rawQueryString req) {- | @instance Show Status@ shows the Haskell structure, which is @@ -203,7 +277,7 @@ -} showStatus :: Status -> Text showStatus stat = - (showt . statusCode) stat <> " " <> (decodeUtf8 . statusMessage) stat + (showt . statusCode) stat <> " " <> (decodeUtf8Safe . statusMessage) stat {- | @@ -229,7 +303,6 @@ Left err -> do uuid <- logProblem err liftIO $ respond (errResponse uuid) - where errResponse :: UUID -> Response errResponse uuid = @@ -254,9 +327,11 @@ logProblem :: (MonadLoggerIO m) => SomeException -> m UUID logProblem err = do uuid <- getUUID - $(logError) - $ "Internal Server Error [" <> showt uuid <> "]: " - <> showt err + logError $ "Internal Server Error" :# + [ "exception" .= show err + , "context" .= displayExceptionContext (someExceptionContext err) + , "id" .= uuid + ] return uuid @@ -386,7 +461,7 @@ ) else app req respond in - foldr (.) id (fmap static files) :: Middleware + foldr ((.) . static) id files :: Middleware ||] where printResource :: String -> IO () @@ -436,5 +511,13 @@ mempty "not found" ) + + +{- | Safely decode UTF-8 bytes to Text, replacing invalid sequences with placeholder. -} +decodeUtf8Safe :: ByteString -> Text +decodeUtf8Safe bytes = + case decodeUtf8' bytes of + Left _err -> " extractBase64 (encodeBase64 bytes) <> ">" + Right val -> val