om-http 0.3.1.1 → 0.6.0.2
raw patch · 3 files changed
Files
- changelog.md +9/−0
- om-http.cabal +26/−21
- src/OM/HTTP.hs +137/−54
+ changelog.md view
@@ -0,0 +1,9 @@+# Changelog++## 0.6.0.2++- Relax upper bounds on `containers` and `time`.++## 0.6.0.1++- Support GHC 9.14.
om-http.cabal view
@@ -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:
src/OM/HTTP.hs view
@@ -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":{..<request details>..}}+ > {"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 "<redacted>"+ 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 -> "<invalid utf8:" <> extractBase64 (encodeBase64 bytes) <> ">"+ Right val -> val