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