Merge branch 'master' of github.com:byteally/webapi

Author: ersran9

cabal.project

@@ -3,8 +3,18 @@ packages:
   webapi-contract
   webapi
   webapi-client-reflex-dom
-  webapi-swagger
+--  webapi-swagger
   webapi-docs
   webapi-xml
-  webapi-openapi
+--  webapi-openapi
   webapi-reflex-dom
+  webapi-test
+--  ../rec/rec
+
+source-repository-package
+  type: git
+  location: https://github.com/byteally/rec
+  tag: 6deffbca324faca6c2c6ded28c38fea8f5edd716
+  subdir: rec
+
+allow-newer: typerep-map:base, typerep-map:ghc-prim

webapi-client-reflex-dom/src/WebApi/Client/Reflex.hs

@@ -171,27 +171,29 @@ clientOrigin baseUrl reqEvt = do
         -- TODO: Handle other xhr response case
         xhrResp = LBS.fromStrict $ T.encodeUtf8 $ maybe T.empty id  $ _xhrResponse_responseText resp
 
-      in case WebApi.Success <$> pure status
-               <*> (Validation $ toParamErr $ decode' (Res :: Resource meth r) xhrResp)
-               <*> respHdr
-               <*> pure () of
-      Validation (Right success) -> success
-      Validation (Left errs1) ->
-        case ApiError
-             <$> pure status
-             <*> (Validation $ toParamErr $ decode' (Res :: Resource meth r) xhrResp)
-             <*> (Just <$> respHdr)
-             <*> (Just <$> (pure ())) of
-          Validation (Right failure) -> (WebApi.Failure . Left) failure
-          Validation (Left errs2) -> 
-            let errs = case HT.statusCode status of
-                  200 -> errs1
-                  _ -> errs2
-            in WebApi.Failure $ Right (OtherError (toException $ ApiErrParseFailException status $ T.intercalate "\n" $ fmap (T.pack . show) errs))
+      in 
+        case statusIsSuccessful status of
+          True ->
+            let res = WebApi.Success <$> pure status
+                        <*> (Validation $ toParamErr $ decode' (Res :: Resource meth r) xhrResp)
+                        <*> respHdr
+                        <*> pure ()
+            in case res of
+              Validation (Right success) -> success
+              Validation (Left errs) ->  WebApi.Failure $ Right (OtherError (toException $ ApiErrParseFailException status $ T.intercalate "\n" $ fmap (T.pack . show) errs))
+          False -> 
+            let res = ApiError 
+                        <$> pure status
+                        <*> (Validation $ toParamErr $ decode' (Res :: Resource meth r) xhrResp)
+                        <*> (Just <$> respHdr)
+                        <*> (Just <$> (pure ()))
+            in case res of
+                Validation (Right failure) -> (WebApi.Failure . Left) failure
+                Validation (Left errs) -> WebApi.Failure $ Right (OtherError (toException $ ApiErrParseFailException status $ T.intercalate "\n" $ fmap (T.pack . show) errs))
 
   pure $ ffor xhrRes $ \case
     Left e -> WebApi.Failure $ Right $ OtherError $ toException e
-    Right r -> fromClientResponse r
+    Right r -> fromClientResponse r 
 
 data ContentDecodeException
   = ContentDecodeException

webapi-reflex-dom/src/WebApi/Reflex/Dom/Router.hs

@@ -89,11 +89,11 @@ data Dom m
 instance SingMethod m => SingMethod (Dom m) where
   singMethod _ = singMethod (Proxy :: Proxy m)
 
-class WebUIServer (s :: *) where
-  type UIInterface s :: *
+class WebUIServer (s :: Type) where
+  type UIInterface s :: Type
   type UIInterface s = s
 
-class UIHandler w (t :: *) s m r where
+class UIHandler w (t :: Type) s m r where
   handler :: s -> Dynamic t (Request m r) -> w (Response m r)
 
 newtype UIRequestRep =
@@ -104,7 +104,7 @@ compactUIServer :: forall api m server t. server t (RouteT t m) -> CompactUIServ
 compactUIServer = CompactUIServer
 
 mkUIRequestRep ::
-  forall route (m :: *) (r :: *).
+  forall route (m :: Type) (r :: Type).
   ( Typeable m
   , Typeable r
   ) => route m r -> UIRequestRep
@@ -122,10 +122,10 @@ data DomResponse =
 
 type ReflexDomApplication t m = (UIRequestRep -> Event t DomRequest) -> Dynamic t DomRequest -> DomRequest -> RouteResult (UIRequestRep, m (Event t DomResponse))
 
-class Monad w => Router (w :: * -> *) (t :: *) (server :: *) (r :: k) (pr :: (*, [*])) where
+class Monad w => Router (w :: Type -> Type) (t :: Type) (server :: Type) (r :: k) (pr :: (Type, [Type])) where
   route :: Proxy '(r, t) -> server -> ParsedRoute t pr -> (Dynamic t [ParamErr] -> w ()) -> ReflexDomApplication t w
 
-instance ( SingMethod (m :: *)
+instance ( SingMethod (m :: Type)
          , Router w t s r '(Dom m, '[])
          , MonadWidget t w
          ) => Router w t s (W.Route '[Dom m] r) pr where
@@ -139,7 +139,7 @@ instance
   ( Router w t s route pr
   , Router w t s routes pr
   , Reflex t
-  ) => Router w t s ((route :: *) ': routes) pr where
+  ) => Router w t s ((route :: Type) ': routes) pr where
   route _ _s parsedRoute page400 getDomReqUpdEv request req =
      (<>)
      (route (Proxy :: Proxy '(route, t)) _s parsedRoute page400 getDomReqUpdEv request req)
@@ -148,20 +148,20 @@ instance
 instance (Monad w, Reflex t) => Router w t s '[] pr where
   route _ _ _ _ _ _ _ = NotMatched
 
-instance (Monad w, Router w t s rest '(m, pp :++ '[Namespace ns])) => Router w t s ((ns :: *) :// (rest :: *)) '(m, pp) where
+instance (Monad w, Router w t s rest '(m, pp :++ '[Namespace ns])) => Router w t s ((ns :: Type) :// (rest :: Type)) '(m, pp) where
   route _ _s parsedRoute page400 getDomReqUpdEv request req =
     route (Proxy :: Proxy '(rest, t)) _s (snocParsedRoute parsedRoute $ NSPiece (Proxy :: Proxy ns)) page400 getDomReqUpdEv request req
 
 instance (Monad w, Router w t s (MarkDyn rest) '(m, (pp :++ '[DynamicPiece piece])), DecodeParam piece, Reflex t)
-                      => Router w t s ((piece :: *) :/ (rest :: *)) '(m, pp) where
+                      => Router w t s ((piece :: Type) :/ (rest :: Type)) '(m, pp) where
   route _ _s parsedRoute page400 getDomReqUpdEv reqDyn req = case pathInfo req of
     (lpth : rpths)  -> case (decodeParam (encodeUtf8 lpth) :: Maybe piece) of
       Just dynPiece -> route (Proxy :: Proxy '((MarkDyn rest), t)) _s (snocParsedRoute parsedRoute $ DPiece dynPiece) page400 getDomReqUpdEv reqDyn (req {pathInfo = rpths})
       Nothing -> NotMatched
     _ -> NotMatched
 
 instance (Reflex t, Monad w, Router w t s (MarkDyn rest) '(m, (pp :++ '[StaticPiece piece])), KnownSymbol piece)
-  => Router w t s ((piece :: Symbol) :/ (rest :: *)) '(m, pp) where
+  => Router w t s ((piece :: Symbol) :/ (rest :: Type)) '(m, pp) where
   route _ _s parsedRoute page400 getDomReqUpdEv reqDyn req = case pathInfo req of
     (lpth : rpths) | lpieceTxt == lpth -> route (Proxy :: Proxy '((MarkDyn rest), t)) _s (snocParsedRoute parsedRoute $ SPiece (Proxy :: Proxy piece)) page400 getDomReqUpdEv reqDyn (req {pathInfo = rpths})
     _ -> NotMatched
@@ -239,7 +239,7 @@ instance ( KnownSymbol rpiece
          , CookieIn m route ~ ()
          , HeaderIn m route ~ ()
          , RequestBody m route ~ '[]
-         ) => Router w t s ((lpiece :: *) :/ (rpiece :: Symbol)) '(m, pp) where
+         ) => Router w t s ((lpiece :: Type) :/ (rpiece :: Symbol)) '(m, pp) where
   route _ serv parsedRoute page400 getDomReqUpdEv reqDyn req = case pathInfo req of
     (lpth : rpth : [])
       | rpieceTxt == rpth -> case (decodeParam (encodeUtf8 lpth) :: Maybe lpiece) of
@@ -314,7 +314,7 @@ instance ( PathParam m (ns :// piece) ~ ()
          , CookieIn m route ~ ()
          , HeaderIn m route ~ ()
          , RequestBody m route ~ '[]
-         ) => Router w t s ((ns :: *) :// (piece :: Symbol)) '(m, pp) where
+         ) => Router w t s ((ns :: Type) :// (piece :: Symbol)) '(m, pp) where
   route _ serv _ page400 getDomReqUpdEv reqDyn req = case pathInfo req of
     (pth : []) | symTxt (Proxy :: Proxy piece) == pth -> Matched (mkUIRequestRep (undefined :: UIRequest m route), getResponse)
     [] | T.null $ symTxt (Proxy :: Proxy piece) -> NotMatched
@@ -471,7 +471,7 @@ toUIApplication r@UIRequest { uiPathParam, uiQueryParam } page404 app = withPath
     go0 =
         map (\(k, v) -> (T.encodeUtf8 k, pure $ T.encodeUtf8 v))
 
-uiApp :: forall (t :: *) server m app r meth ac mp.
+uiApp :: forall (t :: Type) server m app r meth ac mp.
   ( MonadWidget t m
   , MkPathFormatString (app :// r)
   , ToParam 'PathParam (PathParam meth (app :// r))
@@ -500,15 +500,15 @@ emptyParsedRoutes :: ParsedRoute t '(CUSTOM "", '[])
 emptyParsedRoutes = Nil Proxy
 
 
-data PieceType :: * -> * -> * where
+data PieceType :: Type -> Type -> Type where
   SPiece  :: Proxy (p :: Symbol) -> PieceType t (StaticPiece p)
-  NSPiece :: Proxy (ns :: *) -> PieceType t (Namespace ns)
+  NSPiece :: Proxy (ns :: Type) -> PieceType t (Namespace ns)
   DPiece  :: !val -> PieceType t (DynamicPiece val)
 
-data ParsedRoute :: * -> (*, [*]) -> * where
+data ParsedRoute :: Type -> (Type, [Type]) -> Type where
   Nil              :: Proxy method -> ParsedRoute t '(method, '[])
   ConsStaticPiece  :: Proxy (p :: Symbol) -> ParsedRoute t '(method, ps) -> ParsedRoute t '(method, ((StaticPiece p) ': ps))
-  ConsNSPiece      :: Proxy (ns :: *) -> ParsedRoute t '(method, ps) -> ParsedRoute t '(method, ((Namespace ns) ': ps))
+  ConsNSPiece      :: Proxy (ns :: Type) -> ParsedRoute t '(method, ps) -> ParsedRoute t '(method, ((Namespace ns) ': ps))
   ConsDynamicPiece :: !v -> ParsedRoute t '(method, ps) -> ParsedRoute t '(method, ((DynamicPiece v) ': ps))
 
 data RouteResult a =
@@ -520,10 +520,10 @@ instance Semigroup (RouteResult a) where
   NotMatched <> m = m
   Matched a <> _ = Matched a
 
-type family MarkDyn (pp :: *) :: * where
+type family MarkDyn (pp :: Type) :: Type where
   MarkDyn (p1 :/ t)  = (p1 :/ t)
   MarkDyn (p :// t)  = (p :// t)
-  MarkDyn (t :: *)   = DynamicPiece t
+  MarkDyn (t :: Type)   = DynamicPiece t
 
 snocParsedRoute :: ParsedRoute t '(method, ps) -> PieceType t pt -> ParsedRoute t '(method, ps :++ '[pt])
 snocParsedRoute nil@Nil{} (SPiece sym)   = sym `ConsStaticPiece` nil
@@ -569,17 +569,17 @@ getPathParamCtor proutes domreq = fromParsedRoute' (parseDynPiece (pathInfo domr
     parseDynPiece pths (ConsNSPiece _ ps)     = parseDynPiece pths ps
     parseDynPiece (p : pths) (ConsDynamicPiece _v ps) = unsafeDecodePar _v p :* parseDynPiece pths ps
 
-type family AllDecodeParam (dpcs :: [*]) :: Constraint where
+type family AllDecodeParam (dpcs :: [Type]) :: Constraint where
   AllDecodeParam '[] = ()
   AllDecodeParam (t ': ts) = (DecodeParam t, AllDecodeParam ts)
 
-data HList :: * -> [*] -> * where
+data HList :: Type -> [Type] -> Type where
   HNil :: HList t '[]
   (:*) :: !a -> HList t as -> HList t (a ': as)
 infixr 5 :*
 
 -- Compact server
-data CompactUIServer (api :: *) (server :: *) = CompactUIServer server
+data CompactUIServer (api :: Type) (server :: Type) = CompactUIServer server
 
 instance (WebApi api) => WebUIServer (CompactUIServer api s) where
   type UIInterface (CompactUIServer api s) = api
@@ -597,7 +597,7 @@ instance ( ApiContract api m r
       hdl :: handler
       hdl = getField @(GetOpIdName api (OperationId m r)) server
 
-class UnifyHandler (isEq :: Bool) (server :: *) (fn :: Symbol) handlerAct handlerExp where
+class UnifyHandler (isEq :: Bool) (server :: Type) (fn :: Symbol) handlerAct handlerExp where
   unifyHandler :: handlerAct -> handlerExp
 
 instance (handlerAct ~ handlerExp) => UnifyHandler 'True s fn handlerAct handlerExp where

webapi-test/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for webapi-test
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

webapi-test/LICENSE

@@ -0,0 +1,29 @@
+Copyright (c) 2025, Magesh B
+
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the copyright holder nor the names of its
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

webapi-test/quickcheck-dynamic/Test/WebApi/DynamicLogic.hs

@@ -0,0 +1,96 @@
+module Test.WebApi.DynamicLogic
+  ( propDL
+  , prop_api
+  -- , runWebApiTest
+  -- , apiAction
+  , apiForAllVar
+  , getCtxAtTypeDL
+  , arbitraryVal
+  , shrinkVal
+  , module Test.WebApi.StateModel
+  , Reifies
+  , reify 
+  ) where
+
+import Test.WebApi.StateModel
+import Test.WebApi
+import Test.QuickCheck.StateModel
+import Test.QuickCheck.DynamicLogic
+-- import Data.Kind
+import Data.Typeable
+import Test.QuickCheck
+import Test.QuickCheck.Monadic
+import Test.QuickCheck.Monadic qualified as QC
+import Data.Reflection
+import Data.IORef
+import qualified Record
+-- import Control.Monad.IO.Class
+import Control.Monad.Reader
+
+propDL :: forall c xstate apps e s.
+  ( DynLogicModel xstate
+  , RunModel xstate IO
+  , XActionError e ~ Error xstate IO
+  , Typeable e
+  , Show e
+  , Reifies s (WebApiGlobalStateModel c xstate apps)
+  ) => Proxy s -> (forall a. WebApiSessions apps a -> IO a) -> DL (ApiState s c xstate apps) () -> Property
+propDL _ webapiRunner d = forAllDL d (prop_api undefined webapiRunner)
+
+prop_api :: forall c xstate apps e s.
+  ( DynLogicModel xstate
+  , RunModel xstate IO
+  , XActionError e ~ Error xstate IO
+  , Typeable e
+  , Show e
+  , Reifies s (WebApiGlobalStateModel c xstate apps)
+  ) => IORef (Maybe (ApiState s c xstate apps))
+  -> (forall a. WebApiSessions apps a -> IO a)
+  -> Actions (ApiState s c xstate apps)
+  -> Property
+prop_api _newStRef webapiRunner s =
+  -- let
+  --   runner = 
+  monadic (ioProperty . webapiRunner . flip runReaderT initWebApiSessionsCxt) $ do
+    monitor $ counterexample "\nExecution\n"
+    (_anonSt, _env) <- runActions s
+    -- let 
+    --   newApiState = resolveNamedEntities env $ underlyingState anonSt
+    -- liftIO $ writeIORef newStRef (Just newApiState)
+    QC.assert True
+
+-- runWebApiTest :: forall r apps. WebApiGlobalStateModel apps -> (forall (s :: Type). Reifies s (WebApiGlobalStateModel apps) => Proxy s -> r) -> r
+-- runWebApiTest gstate runner = reify gstate (\ps -> runner ps)
+
+-- apiAction ::
+--   ( Typeable a
+--   , Eq (Action (ApiState s apps) a)
+--   , Show (Action (ApiState s apps) a)
+--   , ContextSwitch c
+--   ) => ApiActionM c apps (DL (ApiState s apps)) (ApiAction apps a)
+--   -> ApiActionM c apps (DL (ApiState s apps)) (Val a)
+-- apiAction actM = do
+--   ApiAction act <- actM
+--   liftApiDL $ fmap (Var id) $ action act
+  
+ -- getModelStateDL >>= (\st -> fmap (Var id) . action $ act st)
+
+-- apiAction' :: (Typeable a, Eq (Action s a), Show (Action s a)) => Action s a -> DL s (Val a)
+-- apiAction' = fmap (Var id) . action
+
+apiForAllVar :: forall a s. Typeable a => DL s (Val a)
+apiForAllVar = fmap (Var id) forAllVar
+
+getCtxAtTypeDL :: forall a s. Typeable a => DL s [Val a]
+getCtxAtTypeDL = (fmap (Var id) . ctxAtType @a) <$> getVarContextDL
+
+arbitraryVal :: Typeable a => VarContext -> Gen (Val a)
+arbitraryVal = fmap (Var id) . arbitraryVar
+
+shrinkVal :: forall a. Typeable a => VarContext -> Val a -> [Val a]
+shrinkVal vctx = \case
+  v@Const {} -> [v]
+  Var f v -> fmap (Var f) $ shrinkVar vctx v
+  v@Opt {} -> [v]
+  HKVal f hk -> fmap (HKVal f) $ Record.hoistWithKeyHKA (shrinkVal vctx) hk
+  Pair f (v1, v2) -> fmap (Pair f) $ (,) <$> (shrinkVal vctx v1) <*> (shrinkVal vctx v2)