packages feed

mig 0.2.0.1 → 0.2.1.0

raw patch · 14 files changed

+439/−21 lines, 14 filesdep +timePVP ok

version bump matches the API change (PVP)

Dependencies added: time

API changes (from Hackage documentation)

+ Mig.Core.Class.Plugin: instance (Web.Internal.FormUrlEncoded.FromForm a, Mig.Core.Class.Plugin.ToPlugin b) => Mig.Core.Class.Plugin.ToPlugin (Mig.Core.Types.Route.Cookie a -> b)
+ Mig.Core.Class.Response: SetCookie :: a -> Maybe UTCTime -> Maybe Text -> Maybe Text -> Bool -> Bool -> SetCookie a
+ Mig.Core.Class.Response: [$sel:cookie:SetCookie] :: SetCookie a -> a
+ Mig.Core.Class.Response: [$sel:domain:SetCookie] :: SetCookie a -> Maybe Text
+ Mig.Core.Class.Response: [$sel:expires:SetCookie] :: SetCookie a -> Maybe UTCTime
+ Mig.Core.Class.Response: [$sel:httpOnly:SetCookie] :: SetCookie a -> Bool
+ Mig.Core.Class.Response: [$sel:path:SetCookie] :: SetCookie a -> Maybe Text
+ Mig.Core.Class.Response: [$sel:secure:SetCookie] :: SetCookie a -> Bool
+ Mig.Core.Class.Response: data SetCookie a
+ Mig.Core.Class.Response: defCookie :: a -> SetCookie a
+ Mig.Core.Class.Response: instance GHC.Classes.Eq a => GHC.Classes.Eq (Mig.Core.Class.Response.SetCookie a)
+ Mig.Core.Class.Response: instance GHC.Show.Show a => GHC.Show.Show (Mig.Core.Class.Response.SetCookie a)
+ Mig.Core.Class.Response: setCookie :: (ToForm cookie, IsResp resp) => SetCookie cookie -> resp -> resp
+ Mig.Core.Class.Route: instance (Web.Internal.FormUrlEncoded.FromForm a, Mig.Core.Class.Route.ToRoute b) => Mig.Core.Class.Route.ToRoute (Mig.Core.Types.Route.Cookie a -> b)
+ Mig.Core.Class.Url: Url :: Path -> [(Text, Text)] -> Map Text Text -> Url
+ Mig.Core.Class.Url: [$sel:captures:Url] :: Url -> Map Text Text
+ Mig.Core.Class.Url: [$sel:path:Url] :: Url -> Path
+ Mig.Core.Class.Url: [$sel:queries:Url] :: Url -> [(Text, Text)]
+ Mig.Core.Class.Url: class ToUrl a
+ Mig.Core.Class.Url: data Url
+ Mig.Core.Class.Url: instance (GHC.TypeLits.KnownSymbol sym, Mig.Core.Class.Url.ToUrl b) => Mig.Core.Class.Url.ToUrl (Mig.Core.Types.Route.QueryFlag sym -> b)
+ Mig.Core.Class.Url: instance (GHC.TypeLits.KnownSymbol sym, Web.Internal.HttpApiData.ToHttpApiData a, Mig.Core.Class.Url.ToUrl b) => Mig.Core.Class.Url.ToUrl (Mig.Core.Types.Route.Capture sym a -> b)
+ Mig.Core.Class.Url: instance (GHC.TypeLits.KnownSymbol sym, Web.Internal.HttpApiData.ToHttpApiData a, Mig.Core.Class.Url.ToUrl b) => Mig.Core.Class.Url.ToUrl (Mig.Core.Types.Route.Optional sym a -> b)
+ Mig.Core.Class.Url: instance (GHC.TypeLits.KnownSymbol sym, Web.Internal.HttpApiData.ToHttpApiData a, Mig.Core.Class.Url.ToUrl b) => Mig.Core.Class.Url.ToUrl (Mig.Core.Types.Route.Query sym a -> b)
+ Mig.Core.Class.Url: instance (Mig.Core.Class.Url.ToUrl a, Mig.Core.Class.Url.ToUrl b) => Mig.Core.Class.Url.ToUrl (a Mig.Core.Types.Pair.:| b)
+ Mig.Core.Class.Url: instance (Mig.Core.Class.Url.ToUrl a, Mig.Core.Class.Url.ToUrl b) => Mig.Core.Class.Url.ToUrl (a, b)
+ Mig.Core.Class.Url: instance (Mig.Core.Class.Url.ToUrl a, Mig.Core.Class.Url.ToUrl b, Mig.Core.Class.Url.ToUrl c) => Mig.Core.Class.Url.ToUrl (a, b, c)
+ Mig.Core.Class.Url: instance (Mig.Core.Class.Url.ToUrl a, Mig.Core.Class.Url.ToUrl b, Mig.Core.Class.Url.ToUrl c, Mig.Core.Class.Url.ToUrl d) => Mig.Core.Class.Url.ToUrl (a, b, c, d)
+ Mig.Core.Class.Url: instance Data.Aeson.Types.ToJSON.ToJSON Mig.Core.Class.Url.Url
+ Mig.Core.Class.Url: instance Mig.Core.Class.Url.ToUrl Mig.Core.Class.Url.Url
+ Mig.Core.Class.Url: mapUrl :: ToUrl a => (Url -> Url) -> a -> a
+ Mig.Core.Class.Url: renderUrl :: IsString a => Url -> a
+ Mig.Core.Class.Url: toUrl :: ToUrl a => Server m -> a
+ Mig.Core.Class.Url: type family UrlOf a :: Type
+ Mig.Core.Class.Url: urlArity :: ToUrl a => Int
+ Mig.Core.ServerFun: withCookie :: forall a m. FromForm a => (Maybe a -> ServerFun m) -> ServerFun m
+ Mig.Core.Types.Info: routeHasCapture :: Text -> RouteInfo -> Bool
+ Mig.Core.Types.Info: routeHasOptionalQuery :: Text -> RouteInfo -> Bool
+ Mig.Core.Types.Info: routeHasQuery :: Text -> RouteInfo -> Bool
+ Mig.Core.Types.Info: routeHasQueryFlag :: Text -> RouteInfo -> Bool
+ Mig.Core.Types.Pair: (:|) :: a -> b -> (:|) a b
+ Mig.Core.Types.Pair: data (:|) a b
+ Mig.Core.Types.Route: Cookie :: Maybe a -> Cookie a
+ Mig.Core.Types.Route: newtype Cookie a

Files

mig.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:               mig-version:            0.2.0.1+version:            0.2.1.0 synopsis:           Build lightweight and composable servers description:        The Core for the mig server library.                     With library mig we can build lightweight and composable servers.@@ -47,6 +47,7 @@       Mig.Core.Class.Response       Mig.Core.Class.Route       Mig.Core.Class.Server+      Mig.Core.Class.Url       Mig.Core.OpenApi       Mig.Core.Server       Mig.Core.Server.Cache@@ -54,6 +55,7 @@       Mig.Core.Types       Mig.Core.Types.Http       Mig.Core.Types.Info+      Mig.Core.Types.Pair       Mig.Core.Types.Route   other-modules:       Paths_mig@@ -90,6 +92,7 @@     , openapi3     , safe     , text+    , time     , transformers   default-language: GHC2021 
src/Mig/Core/Class.hs view
@@ -9,3 +9,4 @@ import Mig.Core.Class.Response as X import Mig.Core.Class.Route as X import Mig.Core.Class.Server as X+import Mig.Core.Class.Url as X
src/Mig/Core/Class/Plugin.hs view
@@ -53,7 +53,9 @@ import Data.OpenApi (ToParamSchema (..), ToSchema (..)) import Data.Proxy import Data.String+import Data.Text (Text) import GHC.TypeLits+import Web.FormUrlEncoded (FromForm) import Web.HttpApiData  import Mig.Core.Class.MediaType@@ -157,6 +159,11 @@ instance (FromHttpApiData a, ToParamSchema a, ToPlugin b, KnownSymbol sym) => ToPlugin (OptionalHeader sym a -> b) where   toPluginInfo = addOptionalHeaderInfo @sym @a . toPluginInfo @b   toPluginFun f = \fun -> withOptionalHeader (getName @sym) (\a -> toPluginFun (f (OptionalHeader a)) fun)++-- cookie+instance (FromForm a, ToPlugin b) => ToPlugin (Cookie a -> b) where+  toPluginInfo = addOptionalHeaderInfo @"Cookie" @Text . toPluginInfo @b+  toPluginFun f = \fun -> withCookie (\a -> toPluginFun (f (Cookie a)) fun)  -- query instance (FromHttpApiData a, ToParamSchema a, ToPlugin b, KnownSymbol sym) => ToPlugin (Query sym a -> b) where
src/Mig/Core/Class/Response.hs view
@@ -8,17 +8,26 @@   notImplemented,   redirect,   setHeader,+  SetCookie (..),+  defCookie,+  setCookie, ) where  import Data.Bifunctor+import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as BL import Data.Kind+import Data.List qualified as List+import Data.Maybe import Data.Text (Text)+import Data.Text qualified as Text import Data.Text.Encoding qualified as Text+import Data.Time import Network.HTTP.Media.RenderHeader (RenderHeader (..))-import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)+import Network.HTTP.Types.Header (HeaderName, ResponseHeaders, hSetCookie) import Network.HTTP.Types.Status (Status, internalServerError500, notImplemented501, ok200, status302, status400) import Web.HttpApiData+import Web.Internal.FormUrlEncoded  import Mig.Core.Class.MediaType (AnyMedia, MediaType, ToMediaType (..), ToRespBody (..)) import Mig.Core.Types.Http (Response, ResponseBody (..), noContentResponse)@@ -191,3 +200,62 @@ -- | Redirect to url. It is @bad@ response with 302 status and set header of "Location" to a given URL. redirect :: (IsResp a) => Text -> a redirect url = addHeaders [("Location", Text.encodeUtf8 url)] $ noContent status302++-- | Set cookie as http header from form url encoded value+setCookie :: (ToForm cookie, IsResp resp) => SetCookie cookie -> resp -> resp+setCookie cookie = addHeaders [(hSetCookie, renderSetCookie cookie)]++{-| Set cookie params. For explanation see an article+<https://web.archive.org/web/20170122122852/https://www.nczonline.net/blog/2009/05/05/http-cookies-explained/>+-}+data SetCookie a = SetCookie+  { cookie :: a+  , expires :: Maybe UTCTime+  , domain :: Maybe Text+  , path :: Maybe Text+  , secure :: Bool+  , httpOnly :: Bool+  }+  deriving (Show, Eq)++renderSetCookie :: (ToForm a) => SetCookie a -> ByteString+renderSetCookie value =+  mconcat $+    (BL.toStrict $ urlEncodeForm $ toForm value.cookie)+      : addColons+        ( catMaybes+            [ param "expires" . fmtTime <$> value.expires+            , param "domain" <$> value.domain+            , param "path" <$> value.path+            , flag "secure" value.secure+            , flag "httpOnly" value.httpOnly+            ]+        )+  where+    addColons xs+      | null xs = []+      | otherwise = ";" : List.intersperse ";" xs++    param name v = Text.encodeUtf8 $ name <> v++    flag name = \case+      True -> Just name+      False -> Nothing++    fmtTime :: UTCTime -> Text+    fmtTime = Text.pack . formatTime defaultTimeLocale expiresFormat++    expiresFormat :: String+    expiresFormat = "%a, %d-%b-%Y %X GMT"++-- | Default cookie which sets only the cookie itself.+defCookie :: a -> SetCookie a+defCookie val =+  SetCookie+    { cookie = val+    , expires = Nothing+    , domain = Nothing+    , path = Nothing+    , secure = False+    , httpOnly = False+    }
src/Mig/Core/Class/Route.hs view
@@ -13,12 +13,14 @@ import Data.OpenApi (ToParamSchema (..), ToSchema (..)) import Data.Proxy import Data.String+import Data.Text (Text) import GHC.TypeLits import Mig.Core.Class.MediaType import Mig.Core.Class.Monad import Mig.Core.Class.Response (IsResp (..)) import Mig.Core.ServerFun import Mig.Core.Types+import Web.FormUrlEncoded (FromForm) import Web.HttpApiData  {-| Values that represent routes.@@ -87,6 +89,10 @@ instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToRoute (OptionalHeader sym a -> b) where   toRouteInfo = addOptionalHeaderInfo @sym @a . toRouteInfo @b   toRouteFun f = withOptionalHeader (getName @sym) (toRouteFun . f . OptionalHeader)++instance (FromForm a, ToRoute b) => ToRoute (Cookie a -> b) where+  toRouteInfo = addOptionalHeaderInfo @"Cookie" @Text . toRouteInfo @b+  toRouteFun f = withCookie (toRouteFun . f . Cookie)  instance (ToRoute b) => ToRoute (PathInfo -> b) where   toRouteInfo = toRouteInfo @b
+ src/Mig/Core/Class/Url.hs view
@@ -0,0 +1,251 @@+module Mig.Core.Class.Url (+  Url (..),+  UrlOf,+  renderUrl,+  ToUrl (..),+) where++import Data.Aeson (ToJSON (..))+import Data.Bifunctor+import Data.Kind+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe+import Data.Proxy+import Data.String+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.TypeLits+import Mig.Core.Api (Path (..), PathItem (..), flatApi, fromFlatApi)+import Mig.Core.Class.Route (Route (..))+import Mig.Core.Server (Server (..), getServerPaths)+import Mig.Core.Types.Info (RouteInfo, routeHasCapture, routeHasOptionalQuery, routeHasQuery, routeHasQueryFlag)+import Mig.Core.Types.Pair+import Mig.Core.Types.Route+import Safe (headMay)+import Web.HttpApiData++-- | Url-template type.+data Url = Url+  { path :: Path+  -- ^ relative path+  , queries :: [(Text, Text)]+  -- ^ queries in the URL+  , captures :: Map Text Text+  -- ^ map of captures+  }++instance ToJSON Url where+  toJSON = toJSON . renderUrl @Text++{-| Render URL to string-like value.++TODO: use Text.Builder+-}+renderUrl :: (IsString a) => Url -> a+renderUrl url =+  fromString $ Text.unpack $ appendQuery $ mappend "/" $ Text.intercalate "/" $ fmap fromPathItem url.path.unPath+  where+    fromPathItem :: PathItem -> Text+    fromPathItem = \case+      StaticPath text -> text+      CapturePath name -> fromMaybe ("{" <> name <> "}") $ Map.lookup name url.captures++    appendQuery = case url.queries of+      [] -> id+      _ -> \res -> mconcat [res, "?", query]++    query = Text.intercalate "&" $ fmap (\(name, val) -> mconcat [name, "=", val]) url.queries++-------------------------------------------------------------------------------------+-- render routes to safe URLs++-- | Converts route type to URL function+type family UrlOf a :: Type where+  UrlOf (Send method m a) = Url+  UrlOf (Query name value -> b) = (Query name value -> UrlOf b)+  UrlOf (Optional name value -> b) = (Optional name value -> UrlOf b)+  UrlOf (Capture name value -> b) = (Capture name value -> UrlOf b)+  UrlOf (QueryFlag name -> b) = (QueryFlag name -> UrlOf b)+  UrlOf (Header name value -> b) = UrlOf b+  UrlOf (OptionalHeader name value -> b) = UrlOf b+  UrlOf (Body media value -> b) = UrlOf b+  UrlOf (Cookie value -> b) = UrlOf b+  UrlOf (PathInfo -> b) = UrlOf b+  UrlOf (FullPathInfo -> b) = UrlOf b+  UrlOf (RawRequest -> b) = UrlOf b+  UrlOf (IsSecure -> b) = UrlOf b+  UrlOf (a, b) = (UrlOf a, UrlOf b)+  UrlOf (a, b, c) = (UrlOf a, UrlOf b, UrlOf c)+  UrlOf (a, b, c, d) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d)+  UrlOf (a, b, c, d, e) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d, UrlOf e)+  UrlOf (a, b, c, d, e, f) = (UrlOf a, UrlOf b, UrlOf c, UrlOf d, UrlOf e, UrlOf f)+  UrlOf (a :| b) = UrlOf a :| UrlOf b++{-| Converts server to safe url. We can use it to generate+safe URL constructors to be used in HTML templates+An example of how we can create safe URL's. Note+that order of URL's should be the same as in server definition:++> type GreetingRoute = Get Html+> type BlogPostRoute = Optional "id" BlogPostId -> Get Html+> type ListPostsRoute = Get Html+>+> data Routes = Routes+>   { greeting :: GreetingRoute+>   , blogPost :: BlogPostRoute+>   , listPosts :: ListPostsRoute+>   }+>+> -- URLs+>+> data Urls = Urls+>   { greeting :: UrlOf GreetingRoute+>   , blogPost :: UrlOf BlogPostRoute+>   , listPosts :: UrlOf ListPostsRoute+>   }+>+> {\-| Site URL's+> URL's should be listed in the same order as they appear in the server+> -\}+> urls :: Urls+> urls = Urls{..}+>   where+>     greeting+>       :| blogPost+>       :| listPosts+>         toUrl (server undefined)+-}+class ToUrl a where+  toUrl :: Server m -> a+  mapUrl :: (Url -> Url) -> a -> a+  urlArity :: Int++instance (ToUrl a, ToUrl b) => ToUrl (a :| b) where+  toUrl api = a :| b+    where+      (a, b) = toUrl api+  mapUrl f (a :| b) = (mapUrl f a :| mapUrl f b)+  urlArity = urlArity @(a, b)++instance (ToUrl a, ToUrl b) => ToUrl (a, b) where+  toUrl (Server api) = (toUrl (Server apiA), toUrl (Server apiB))+    where+      (apiA, apiB) = bimap fromFlatApi fromFlatApi $ Prelude.splitAt (urlArity @a) (flatApi api)++  mapUrl f (a, b) = (mapUrl f a, mapUrl f b)+  urlArity = urlArity @a + urlArity @b++instance (ToUrl a, ToUrl b, ToUrl c) => ToUrl (a, b, c) where+  toUrl server = fromPair $ toUrl @(a, (b, c)) server+    where+      fromPair (a, (b, c)) = (a, b, c)++  mapUrl f (a, b, c) = (mapUrl f a, mapUrl f b, mapUrl f c)+  urlArity = urlArity @a + urlArity @b + urlArity @c++instance (ToUrl a, ToUrl b, ToUrl c, ToUrl d) => ToUrl (a, b, c, d) where+  toUrl server = fromPair $ toUrl @(a, (b, c, d)) server+    where+      fromPair (a, (b, c, d)) = (a, b, c, d)++  mapUrl f (a, b, c, d) = (mapUrl f a, mapUrl f b, mapUrl f c, mapUrl f d)+  urlArity = urlArity @a + urlArity @b + urlArity @c + urlArity @d++instance ToUrl Url where+  toUrl server = case getServerPaths server of+    url : _ -> Url url [] mempty+    _ -> Url mempty mempty mempty++  mapUrl f a = f a+  urlArity = 1++-- query++instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Query sym a -> b) where+  toUrl server = \(Query val) ->+    whenOrError (hasQuery (getName @sym) server) noQuery $+      mapUrl (insertQuery (getName @sym) (toUrlPiece val)) (toUrl @b server)+    where+      noQuery = noInputMessage ("query with name: " <> getName @sym) server++  mapUrl f a = \query -> mapUrl f (a query)+  urlArity = urlArity @b++insertQuery :: Text -> Text -> Url -> Url+insertQuery name val url = url{queries = (name, val) : url.queries}++hasQuery :: Text -> Server m -> Bool+hasQuery name = hasInput (routeHasQuery name)++-- optional query++instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Optional sym a -> b) where+  toUrl server = \(Optional mVal) ->+    whenOrError (hasOptionalQuery (getName @sym) server) noOptionalQuery $+      mapUrl (maybe id (insertQuery (getName @sym) . toUrlPiece) mVal) (toUrl @b server)+    where+      noOptionalQuery = noInputMessage ("optional query with name: " <> getName @sym) server++  mapUrl f a = \query -> mapUrl f (a query)+  urlArity = urlArity @b++hasOptionalQuery :: Text -> Server m -> Bool+hasOptionalQuery name = hasInput (routeHasOptionalQuery name)++-- query flag++instance (KnownSymbol sym, ToUrl b) => ToUrl (QueryFlag sym -> b) where+  toUrl server = \(QueryFlag val) ->+    whenOrError (hasQueryFlag (getName @sym) server) noQueryFlag $+      mapUrl (insertQuery (getName @sym) (toUrlPiece val)) (toUrl @b server)+    where+      noQueryFlag = noInputMessage ("query flag with name: " <> getName @sym) server++  mapUrl f a = \query -> mapUrl f (a query)+  urlArity = urlArity @b++hasQueryFlag :: Text -> Server m -> Bool+hasQueryFlag name = hasInput (routeHasQueryFlag name)++-- capture++instance (KnownSymbol sym, ToHttpApiData a, ToUrl b) => ToUrl (Capture sym a -> b) where+  toUrl server = \(Capture val) ->+    whenOrError (hasCapture (getName @sym) server) noCapture $+      mapUrl (insertCapture (getName @sym) (toUrlPiece val)) (toUrl @b server)+    where+      noCapture = noInputMessage ("Capture with name: " <> getName @sym) server++  mapUrl f a = \capture -> mapUrl f (a capture)+  urlArity = urlArity @b++insertCapture :: Text -> Text -> Url -> Url+insertCapture name val url = url{captures = Map.insert name val url.captures}++hasCapture :: Text -> Server m -> Bool+hasCapture name = hasInput (routeHasCapture name)++-------------------------------------------------------------------------------------+-- utils++getName :: forall sym a. (KnownSymbol sym, IsString a) => a+getName = fromString (symbolVal (Proxy @sym))++hasInput :: (RouteInfo -> Bool) -> Server m -> Bool+hasInput check (Server api) =+  maybe False (check . (.info) . snd) $ headMay $ flatApi api++noInputMessage :: String -> Server m -> String+noInputMessage item (Server api) =+  unlines+    [ unwords ["Server has no", item, "at route", route]+    , "Check the order of routes on the left side of toUrl expression"+    ]+  where+    route = maybe "unknown" (Text.unpack . toUrlPiece . fst) $ headMay (flatApi api)++whenOrError :: Bool -> String -> a -> a+whenOrError cond message a+  | cond = a+  | otherwise = error message
src/Mig/Core/ServerFun.hs view
@@ -19,6 +19,7 @@   withCapture,   withHeader,   withOptionalHeader,+  withCookie,   withPathInfo,   withFullPathInfo,   handleServerError,@@ -39,6 +40,7 @@ import Mig.Core.Types import Network.HTTP.Types.Header (HeaderName) import Network.HTTP.Types.Status (status500)+import Web.FormUrlEncoded (FromForm (..), urlDecodeForm) import Web.HttpApiData  {-| Low-level representation of the server.@@ -143,6 +145,14 @@ withOptionalHeader name act = withQueryBy getVal act   where     getVal req = eitherToMaybe . parseHeader =<< Map.lookup name req.headers++withCookie :: forall a m. (FromForm a) => (Maybe a -> ServerFun m) -> ServerFun m+withCookie act = withOptionalHeader @Text "Cookie" (act . (parseCookie =<<))+  where+    parseCookie :: Text -> Maybe a+    parseCookie txt = do+      form <- eitherToMaybe $ urlDecodeForm $ BL.fromStrict $ Text.encodeUtf8 txt+      eitherToMaybe $ fromForm form  -- | Reads full path (without qury parameters) withPathInfo :: ([Text] -> ServerFun m) -> ServerFun m
src/Mig/Core/Types.hs view
@@ -7,4 +7,5 @@  import Mig.Core.Types.Http as X import Mig.Core.Types.Info as X+import Mig.Core.Types.Pair as X import Mig.Core.Types.Route as X
src/Mig/Core/Types/Info.hs view
@@ -26,11 +26,17 @@   addQueryFlagInfo,   addOptionalInfo,   addCaptureInfo,++  -- * checks+  routeHasQuery,+  routeHasOptionalQuery,+  routeHasQueryFlag,+  routeHasCapture, ) where  import Data.List.Extra (firstJust) import Data.Map.Strict qualified as Map-import Data.OpenApi+import Data.OpenApi (Definitions, Referenced, Schema, ToParamSchema (..), ToSchema (..), declareSchemaRef) import Data.OpenApi.Declare (runDeclare) import Data.Proxy import Data.String@@ -207,6 +213,45 @@ -- | Adds request body to API schema addBodyInfo :: forall ty a. (ToMediaType ty, ToSchema a) => RouteInfo -> RouteInfo addBodyInfo = addRouteInput (ReqBodyInput (toMediaType @ty) (toSchemaDefs @a))++---------------------------------------------+-- checks++-- | Check that route has query with given name+routeHasQuery :: Text -> RouteInfo -> Bool+routeHasQuery expectedName = routeHasInput isQuery+  where+    isQuery = \case+      QueryInput (IsRequired True) name _ -> expectedName == name+      _ -> False++-- | Check that route has query with given name+routeHasOptionalQuery :: Text -> RouteInfo -> Bool+routeHasOptionalQuery expectedName = routeHasInput isOptionalQuery+  where+    isOptionalQuery = \case+      QueryInput (IsRequired False) name _ -> expectedName == name+      _ -> False++-- | Check that route has query with given name+routeHasQueryFlag :: Text -> RouteInfo -> Bool+routeHasQueryFlag expectedName = routeHasInput isQueryFlag+  where+    isQueryFlag = \case+      QueryFlagInput name -> expectedName == name+      _ -> False++-- | Check that route has query with given name+routeHasCapture :: Text -> RouteInfo -> Bool+routeHasCapture expectedName = routeHasInput isCapture+  where+    isCapture = \case+      CaptureInput name _ -> expectedName == name+      _ -> False++-- | Check that route has certain input+routeHasInput :: (RouteInput -> Bool) -> RouteInfo -> Bool+routeHasInput check info = any (check . (.content)) info.inputs  --------------------------------------------- -- utils
+ src/Mig/Core/Types/Pair.hs view
@@ -0,0 +1,9 @@+-- | Pair with infix constructor.+module Mig.Core.Types.Pair (+  (:|) (..),+) where++{-| Infix synonym for pair. It can be useful to stack together+many client functions in the output of @toClient@ function.+-}+data (:|) a b = a :| b
src/Mig/Core/Types/Route.hs view
@@ -8,6 +8,7 @@   Capture (..),   Header (..),   OptionalHeader (..),+  Cookie (..),   PathInfo (..),   FullPathInfo (..),   RawRequest (..),@@ -93,6 +94,21 @@ > (OptionalHeader (Just bar)) :: OptionalHeader "foo" barType -} newtype OptionalHeader (sym :: Symbol) a = OptionalHeader (Maybe a)++{-| Reads a cookie. It's an optional header with name "Cookie".+The cookie is URL-encoded and read with instnace of FromForm class.++> data MyCookie = MyCookie+>   { secret :: Text+>   , count :: Int+>   }+>   deriving (Generic, FromForm)+>+> > "secret=lolkek&count=101"+>+> (Cookie (Just (MyCookie { secret = "lolkek", count = 101 }))) :: Cookie MyCookie+-}+newtype Cookie a = Cookie (Maybe a)  {-| Reads current path info. 
test/Test/Server/Counter.hs view
@@ -6,6 +6,7 @@ import Data.Maybe import Data.Text qualified as Text import Mig.Core+import Mig.Core qualified as Request (Request (..)) import Network.HTTP.Types.Method (methodPost) import Test.Hspec import Test.Server.Common@@ -82,8 +83,8 @@     putReq increment =       emptyReq         { method = methodPost-        , path = ["counter", "put", Text.pack (show increment)]+        , Request.path = ["counter", "put", Text.pack (show increment)]         }      getReq :: Request-    getReq = emptyReq{path = ["counter", "get"]}+    getReq = emptyReq{Request.path = ["counter", "get"]}
test/Test/Server/Hello.hs view
@@ -55,10 +55,10 @@         it "wrong output media type" $ do           serverFun (helloReq{Request.headers = Map.fromList [("Accept", "text/html")]}) `shouldReturn` Nothing -    helloReq = emptyReq{path = ["api", "v1", "hello"]}+    helloReq = emptyReq{Request.path = ["api", "v1", "hello"]}     helloResp = Just $ jsonResp @Text "hello" -    byeReq = emptyReq{path = ["api", "v1", "bye"]}+    byeReq = emptyReq{Request.path = ["api", "v1", "bye"]}     byeResp = Just $ jsonResp @Text "bye" -    wrongPathReq = emptyReq{path = ["api", "v2", "hello"]}+    wrongPathReq = emptyReq{Request.path = ["api", "v2", "hello"]}
test/Test/Server/RouteArgs.hs view
@@ -206,14 +206,14 @@     queryReq :: Request     queryReq =       emptyReq-        { path = ["api", "succ", "query"]+        { Request.path = ["api", "succ", "query"]         , query = toQuery @Int "value" 1         }      twoQueryReq :: Int -> Int -> Request     twoQueryReq a b =       emptyReq-        { path = ["api", "add"]+        { Request.path = ["api", "add"]         , query = toQuery "a" a <> toQuery "b" b         } @@ -228,7 +228,7 @@     optionalQueryReq :: Request     optionalQueryReq =       emptyReq-        { path = ["api", "succ", "optional"]+        { Request.path = ["api", "succ", "optional"]         , query = toQuery @Int "value" 1         } @@ -244,7 +244,7 @@     queryFlagReq :: Maybe Bool -> Int -> Int -> Request     queryFlagReq mFlag a b =       emptyReq-        { path = ["api", "add-if"]+        { Request.path = ["api", "add-if"]         , query = mconcat [toQuery "a" a, toQuery "b" b] <> maybe mempty (toQuery "perform") mFlag         } @@ -260,7 +260,7 @@     headerReq :: Request     headerReq =       emptyReq-        { path = ["api", "succ", "header"]+        { Request.path = ["api", "succ", "header"]         , Request.headers = Map.singleton "value" (BL.toStrict $ Json.encode @Int 1)         } @@ -275,7 +275,7 @@     optionalHeaderReq :: Request     optionalHeaderReq =       emptyReq-        { path = ["api", "succ", "optional-header"]+        { Request.path = ["api", "succ", "optional-header"]         , Request.headers = Map.singleton "value" (BL.toStrict $ Json.encode @Int 1)         } @@ -292,7 +292,7 @@     captureReq :: [Int] -> Request     captureReq args =       emptyReq-        { path = ["api", "mul"] <> fmap (Text.pack . show) args+        { Request.path = ["api", "mul"] <> fmap (Text.pack . show) args         }      -- body@@ -309,7 +309,7 @@     bodyReq :: Method -> Int -> Int -> Request     bodyReq reqMethod a b =       emptyReq-        { path = ["api", "add-json"]+        { Request.path = ["api", "add-json"]         , method = reqMethod         , readBody = pure $ Right $ Json.encode $ AddInput a b         , Request.headers = jsonHeaders@@ -318,7 +318,7 @@     noBodyReq :: Request     noBodyReq =       emptyReq-        { path = ["api", "add-json"]+        { Request.path = ["api", "add-json"]         , method = methodPost         , Request.headers = jsonHeaders         }@@ -326,7 +326,7 @@     sqrtBodyReq :: Float -> Request     sqrtBodyReq a =       emptyReq-        { path = ["api", "square-root"]+        { Request.path = ["api", "square-root"]         , method = methodPost         , readBody = pure $ Right $ Json.encode a         , Request.headers = jsonHeaders@@ -345,7 +345,7 @@     statusReq :: Request     statusReq =       emptyReq-        { path = ["api", "response", "status"]+        { Request.path = ["api", "response", "status"]         }      -- response headers@@ -365,7 +365,7 @@     customHeaderReq :: Text -> Text -> Request     customHeaderReq name value =       emptyReq-        { path = ["api", "response", "header", name, value]+        { Request.path = ["api", "response", "header", name, value]         }      -- response errors@@ -390,5 +390,5 @@     customErrorReq :: [Text] -> Request     customErrorReq args =       emptyReq-        { path = ["api", "response"] <> args+        { Request.path = ["api", "response"] <> args         }