om-http 0.3.1.1 → 0.4.0.0
raw patch · 2 files changed
+119/−65 lines, 2 filesdep +base64dep +case-insensitivedep +monad-logger-aesondep −monad-loggerdep ~bytestringdep ~om-showdep ~textPVP ok
version bump matches the API change (PVP)
Dependencies added: base64, case-insensitive, monad-logger-aeson
Dependencies removed: monad-logger
Dependency ranges changed: bytestring, om-show, text
API changes (from Hackage documentation)
Files
- om-http.cabal +22/−20
- src/OM/HTTP.hs +97/−45
om-http.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: om-http-version: 0.3.1.1+version: 0.4.0.0 synopsis: Http utilities. description: Random HTTP utilities. homepage: https://github.com/owensmurray/om-http@@ -17,25 +17,27 @@ 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+ , async >= 2.2.4 && < 2.3+ , base >= 4.15.1.0 && < 4.21+ , base64 >= 1.0 && < 1.1+ , bytestring >= 0.11.1.0 && < 0.13+ , case-insensitive >= 1.2.1.0 && < 1.3+ , 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-aeson >= 0.4.1.3 && < 0.5+ , network >= 3.1.2.7 && < 3.3+ , om-show >= 0.1.2.8 && < 0.2+ , safe-exceptions >= 0.1.7.3 && < 0.2+ , servant >= 0.19 && < 0.21+ , template-haskell >= 2.17.0.0 && < 2.23+ , text >= 2.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 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,56 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_)-import Control.Exception.Safe (SomeException, bracket, finally, throwM,- tryAny)+import Control.Exception (try)+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.Base64.Types (extractBase64) import Data.ByteString (ByteString)+import Data.ByteString.Base64 (encodeBase64) import Data.List ((\\)) import Data.Maybe (catMaybes) 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, 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+ ( Request+ ( isSecure, pathInfo, rawPathInfo, rawQueryString, remoteHost+ , requestHeaders, requestMethod+ )+ , Application, Middleware, Response, ResponseReceived, mapResponseHeaders+ , responseLBS, responseRaw, responseStatus+ ) import Network.Wai.Handler.Warp (run) 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 +80,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 @@ -165,8 +178,8 @@ 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. -}@@ -175,27 +188,58 @@ -> Middleware requestLogging logging 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)+ <> ": "+ <> 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)+ ]+ 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)]+ 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 +247,7 @@ -} showStatus :: Status -> Text showStatus stat =- (showt . statusCode) stat <> " " <> (decodeUtf8 . statusMessage) stat+ (showt . statusCode) stat <> " " <> (decodeUtf8Safe . statusMessage) stat {- |@@ -229,7 +273,6 @@ Left err -> do uuid <- logProblem err liftIO $ respond (errResponse uuid)- where errResponse :: UUID -> Response errResponse uuid =@@ -254,9 +297,10 @@ 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+ , "id" .= uuid+ ] return uuid @@ -386,7 +430,7 @@ ) else app req respond in- foldr (.) id (fmap static files) :: Middleware+ foldr ((.) . static) id files :: Middleware ||] where printResource :: String -> IO ()@@ -436,5 +480,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