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 +4/−1
- src/Mig/Core/Class.hs +1/−0
- src/Mig/Core/Class/Plugin.hs +7/−0
- src/Mig/Core/Class/Response.hs +69/−1
- src/Mig/Core/Class/Route.hs +6/−0
- src/Mig/Core/Class/Url.hs +251/−0
- src/Mig/Core/ServerFun.hs +10/−0
- src/Mig/Core/Types.hs +1/−0
- src/Mig/Core/Types/Info.hs +46/−1
- src/Mig/Core/Types/Pair.hs +9/−0
- src/Mig/Core/Types/Route.hs +16/−0
- test/Test/Server/Counter.hs +3/−2
- test/Test/Server/Hello.hs +3/−3
- test/Test/Server/RouteArgs.hs +13/−13
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 }