Merge pull request #47 from anton-k/full-path-info

add FullPathInfo request input

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

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)
 

mig-extra/src/Mig/Extra/Server/Common.hs

@@ -49,6 +49,7 @@ module Mig.Extra.Server.Common (
   Optional (..),
   Header (..),
   PathInfo (..),
+  FullPathInfo (..),
   RawRequest (..),
 
   -- ** response

mig-server/src/Mig.hs

@@ -79,6 +79,7 @@ module Mig (
   Body (..),
   Header (..),
   PathInfo (..),
+  FullPathInfo (..),
   RawRequest (..),
 
   -- ** response

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

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

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
 

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

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