diff --git a/examples/mig-example-apps/Html/src/Server.hs b/examples/mig-example-apps/Html/src/Server.hs index c7ef0a2..1c76f02 100644 --- a/examples/mig-example-apps/Html/src/Server.hs +++ b/examples/mig-example-apps/Html/src/Server.hs @@ -9,7 +9,6 @@ import Control.Monad import Data.ByteString (ByteString) import Data.Text qualified as Text import FileEmbedLzma -import Safe (headMay) import Mig.Html.IO import System.Random @@ -60,9 +59,9 @@ server site = ] logRoutes :: Server IO -> Server IO - logRoutes = applyPlugin $ \(PathInfo path) -> prependServerAction $ - when (path /= ["favicon.ico"] && headMay path /= Just "static") $ do - logRoute site (Text.intercalate "/" path) + logRoutes = applyPlugin $ \(FullPathInfo path) -> prependServerAction $ + when (not $ path == "favicon.ico" || Text.isPrefixOf "static" path) $ do + logRoute site path ------------------------------------------------------------------------------------- -- server handlers diff --git a/mig-extra/src/Mig/Extra/Plugin/Trace.hs b/mig-extra/src/Mig/Extra/Plugin/Trace.hs index 32c07e7..30b3cf9 100644 --- a/mig-extra/src/Mig/Extra/Plugin/Trace.hs +++ b/mig-extra/src/Mig/Extra/Plugin/Trace.hs @@ -29,7 +29,6 @@ import Data.CaseInsensitive qualified as CI import Data.Map.Strict qualified as Map import Data.String import Data.Text (Text) -import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Time import Data.Yaml qualified as Yaml @@ -94,7 +93,7 @@ ppReq verbosity now body req = [ maybe [] (pure . ("time" .=)) now , [ "type" .= ("http-request" :: Text) - , "path" .= toPath req + , "path" .= toFullPath req , "method" .= Text.decodeUtf8 (renderHeader req.method) ] ] @@ -152,7 +151,7 @@ ppResp verbosity now dur req resp = [ "time" .= now , "duration" .= dur , "type" .= ("http-response" :: Text) - , "path" .= toPath req + , "path" .= toFullPath req , "status" .= resp.status.statusCode , "method" .= Text.decodeUtf8 (renderHeader req.method) ] @@ -184,19 +183,6 @@ defaultPrinter = addLogPrefix :: Json.Value -> Json.Value addLogPrefix val = Json.object ["log" .= val] -toPath :: Request -> Text -toPath req = Text.intercalate "/" req.path <> queries - where - queries - | Map.null req.query = mempty - | otherwise = "?" <> Text.intercalate "&" (fmap fromQuery (Map.toList req.query)) - - fromQuery (name, mVal) = case mVal of - Just val -> nameText <> "=" <> Text.decodeUtf8 val - Nothing -> nameText - where - nameText = Text.decodeUtf8 name - headerName :: CI ByteString -> Json.Key headerName name = Json.fromText (Text.decodeUtf8 $ CI.foldedCase name) diff --git a/mig-extra/src/Mig/Extra/Server/Common.hs b/mig-extra/src/Mig/Extra/Server/Common.hs index c0b1635..e32bdd3 100644 --- a/mig-extra/src/Mig/Extra/Server/Common.hs +++ b/mig-extra/src/Mig/Extra/Server/Common.hs @@ -49,6 +49,7 @@ module Mig.Extra.Server.Common ( Optional (..), Header (..), PathInfo (..), + FullPathInfo (..), RawRequest (..), -- ** response diff --git a/mig-server/src/Mig.hs b/mig-server/src/Mig.hs index 16b1387..b46eec6 100644 --- a/mig-server/src/Mig.hs +++ b/mig-server/src/Mig.hs @@ -79,6 +79,7 @@ module Mig ( Body (..), Header (..), PathInfo (..), + FullPathInfo (..), RawRequest (..), -- ** response diff --git a/mig/src/Mig/Core/Class/Plugin.hs b/mig/src/Mig/Core/Class/Plugin.hs index 05072c8..d5fb88d 100644 --- a/mig/src/Mig/Core/Class/Plugin.hs +++ b/mig/src/Mig/Core/Class/Plugin.hs @@ -120,7 +120,12 @@ instance (ToPlugin a) => ToPlugin (PathInfo -> a) where toPluginInfo = id toPluginFun f = \fun -> withPathInfo (\path -> toPluginFun (f (PathInfo path)) fun) --- path info +-- full path info +instance (ToPlugin a) => ToPlugin (FullPathInfo -> a) where + toPluginInfo = id + toPluginFun f = \fun -> withFullPathInfo (\path -> toPluginFun (f (FullPathInfo path)) fun) + +-- is secure instance (ToPlugin a) => ToPlugin (IsSecure -> a) where toPluginInfo = id toPluginFun f = \fun -> \req -> (toPluginFun (f (IsSecure req.isSecure)) fun) req diff --git a/mig/src/Mig/Core/Class/Route.hs b/mig/src/Mig/Core/Class/Route.hs index f0a1b67..f7f7ddb 100644 --- a/mig/src/Mig/Core/Class/Route.hs +++ b/mig/src/Mig/Core/Class/Route.hs @@ -90,6 +90,10 @@ instance (ToRoute b) => ToRoute (PathInfo -> b) where toRouteInfo = toRouteInfo @b toRouteFun f = withPathInfo (toRouteFun . f . PathInfo) +instance (ToRoute b) => ToRoute (FullPathInfo -> b) where + toRouteInfo = toRouteInfo @b + toRouteFun f = withFullPathInfo (toRouteFun . f . FullPathInfo) + instance (ToRoute b) => ToRoute (RawRequest -> b) where toRouteInfo = toRouteInfo @b toRouteFun f = \req -> toRouteFun (f (RawRequest req)) req diff --git a/mig/src/Mig/Core/ServerFun.hs b/mig/src/Mig/Core/ServerFun.hs index e998b69..ed4833b 100644 --- a/mig/src/Mig/Core/ServerFun.hs +++ b/mig/src/Mig/Core/ServerFun.hs @@ -19,6 +19,7 @@ module Mig.Core.ServerFun ( withHeader, withOptionalHeader, withPathInfo, + withFullPathInfo, handleError, ) where @@ -146,6 +147,10 @@ withOptionalHeader name act = withQueryBy getVal act withPathInfo :: ([Text] -> ServerFun m) -> ServerFun m withPathInfo act = \req -> act req.path req +-- | Reads full path (without qury parameters) +withFullPathInfo :: (Text -> ServerFun m) -> ServerFun m +withFullPathInfo act = \req -> act (toFullPath req) req + sendResponse :: (Functor m) => m Response -> ServerFun m sendResponse act = const $ fmap Just act diff --git a/mig/src/Mig/Core/Types/Http.hs b/mig/src/Mig/Core/Types/Http.hs index 1fcfe25..f045d68 100644 --- a/mig/src/Mig/Core/Types/Http.hs +++ b/mig/src/Mig/Core/Types/Http.hs @@ -19,14 +19,17 @@ module Mig.Core.Types.Http ( -- * utils setRespStatus, addRespHeaders, + toFullPath, ) where import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as BL import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Data.String import Data.Text (Text) import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text import Data.Text.Lazy qualified as TL import Mig.Core.Class.MediaType (MediaType, ToMediaType (..), ToRespBody (..)) import Network.HTTP.Media.RenderHeader @@ -129,3 +132,16 @@ badResponse :: forall mime a. (ToRespBody mime a) => Status -> a -> Response badResponse status = Response status (setContent media) . RawResp media . toRespBody @mime where media = toMediaType @mime + +toFullPath :: Request -> Text +toFullPath req = Text.intercalate "/" req.path <> queries + where + queries + | Map.null req.query = mempty + | otherwise = "?" <> Text.intercalate "&" (fmap fromQuery (Map.toList req.query)) + + fromQuery (name, mVal) = case mVal of + Just val -> nameText <> "=" <> Text.decodeUtf8 val + Nothing -> nameText + where + nameText = Text.decodeUtf8 name diff --git a/mig/src/Mig/Core/Types/Route.hs b/mig/src/Mig/Core/Types/Route.hs index 45300b2..2043a07 100644 --- a/mig/src/Mig/Core/Types/Route.hs +++ b/mig/src/Mig/Core/Types/Route.hs @@ -9,6 +9,7 @@ module Mig.Core.Types.Route ( Header (..), OptionalHeader (..), PathInfo (..), + FullPathInfo (..), RawRequest (..), IsSecure (..), @@ -97,6 +98,12 @@ newtype OptionalHeader (sym :: Symbol) a = OptionalHeader (Maybe a) -} newtype PathInfo = PathInfo [Text] +{-| Reads current full-path info with queries. + +> "api/foo/bar?param=value" ==> FullPathInfo "api/foo/bar?param=value" +-} +newtype FullPathInfo = FullPathInfo Text + -- | Read low-level request. Note that it does not affect the API schema newtype RawRequest = RawRequest Request