Skip to content

Commit 61ca47f

Browse files
mageshbmageshb
committed
Add serverAppTyped
Init webapi-test
1 parent 114b0fa commit 61ca47f

8 files changed

Lines changed: 766 additions & 0 deletions

File tree

‎cabal.project‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,3 +8,4 @@ packages:
88
webapi-xml
99
webapi-openapi
1010
webapi-reflex-dom
11+
webapi-test

‎webapi-test/CHANGELOG.md‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
# Revision history for webapi-test
2+
3+
## 0.1.0.0 -- YYYY-mm-dd
4+
5+
* First version. Released on an unsuspecting world.

‎webapi-test/LICENSE‎

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

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

Lines changed: 62 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,62 @@
1+
module Test.WebApi.DynamicLogic
2+
( successCall
3+
, errorCall
4+
, someExceptionCall
5+
, propDL
6+
, prop_api
7+
, module Test.WebApi.StateModel
8+
) where
9+
10+
import Test.WebApi.StateModel
11+
import Test.WebApi
12+
import Test.QuickCheck.StateModel
13+
import Test.QuickCheck.DynamicLogic
14+
import WebApi.Contract
15+
import WebApi.Param
16+
import WebApi.ContentTypes
17+
import Control.Exception (SomeException)
18+
import Data.Kind
19+
import Data.Typeable
20+
import Test.QuickCheck
21+
import Test.QuickCheck.Monadic
22+
import Test.QuickCheck.Monadic qualified as QC
23+
import Test.QuickCheck.Extras
24+
25+
26+
successCall :: forall meth r app apps. WebApiActionCxt apps meth app r =>
27+
ClientRequest meth (app :// r)
28+
-> DL (ApiState apps) (Var (ApiOut meth (app :// r)))
29+
successCall creq = action (mkWebApiAction (SuccessCall creq))
30+
31+
errorCall :: forall meth r app apps.WebApiActionCxt apps meth app r =>
32+
ClientRequest meth (app :// r)
33+
-> DL (ApiState apps) (Var (ApiErr meth (app :// r)))
34+
errorCall creq = action (mkWebApiAction (ErrorCall creq))
35+
36+
someExceptionCall :: forall meth r app apps. WebApiActionCxt apps meth app r =>
37+
ClientRequest meth (app :// r)
38+
-> DL (ApiState apps) (Var SomeException)
39+
someExceptionCall creq = action (mkWebApiAction (SomeExceptionCall creq))
40+
41+
propDL :: (forall a. WebApiSessions apps a -> IO a) -> DL (ApiState apps) () -> Property
42+
propDL webapiRunner d = forAllDL d (prop_api webapiRunner)
43+
44+
prop_api :: forall apps. (forall a. WebApiSessions apps a -> IO a) -> Actions (ApiState apps) -> Property
45+
prop_api webapiRunner s =
46+
monadic (ioProperty . webapiRunner) $ do
47+
monitor $ counterexample "\nExecution\n"
48+
_ <- runActions s
49+
QC.assert True
50+
51+
{-
52+
prop_api :: forall apps. WebApiSessionsConfig apps -> Actions (ApiState apps) -> Property
53+
prop_api _ s =
54+
monadicIO $ do
55+
monitor $ counterexample "\nExecution\n"
56+
_ <- runPropertyStateT (runPropertyReaderT (hoistPropM (runWebApiSessions @apps) WebApiSessions $ runActions s) undefined) undefined
57+
QC.assert True
58+
59+
60+
hoistPropM :: (forall x. m x -> n x) -> (forall x. n x -> m x) -> PropertyM m a -> PropertyM n a
61+
hoistPropM fw bw p = MkPropertyM $ \hf -> fmap fw $ unPropertyM p ((fmap . fmap) bw hf)
62+
-}

‎webapi-test/quickcheck-dynamic/Test/WebApi/StateModel.hs‎

Lines changed: 113 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,113 @@
1+
{-# LANGUAGE UndecidableInstances #-}
2+
module Test.WebApi.StateModel
3+
( WebApiAction (..)
4+
, ApiState (..)
5+
, WebApiActionCxt
6+
, mkWebApiAction
7+
, getOpIdFromRequest
8+
) where
9+
10+
import Test.WebApi
11+
import Test.QuickCheck.StateModel
12+
import Test.QuickCheck.DynamicLogic (DynLogicModel (..))
13+
import WebApi.Contract
14+
import WebApi.Param
15+
import WebApi.ContentTypes
16+
import Control.Exception (SomeException)
17+
import Data.Kind
18+
import Data.Typeable
19+
import Data.Coerce
20+
import GHC.TypeLits
21+
22+
type WebApiActionCxt (apps :: [Type]) meth (app :: Type) r =
23+
( ToParam 'PathParam (PathParam meth (app://r))
24+
, ToParam 'QueryParam (QueryParam meth (app://r))
25+
, FromHeader (HeaderOut meth (app :// r))
26+
, FromParam Cookie (CookieOut meth (app :// r))
27+
, Decodings (ContentTypes meth (app :// r)) (ApiOut meth (app :// r))
28+
, Decodings (ContentTypes meth (app :// r)) (ApiErr meth (app :// r))
29+
, SingMethod meth
30+
, WebApi app
31+
, Typeable app
32+
, Typeable (ApiOut meth (app :// r))
33+
, Typeable (ApiErr meth (app :// r))
34+
, Typeable r
35+
, AppIsElem app apps
36+
, KnownSymbol (GetOpIdName (OperationId meth (app :// r)))
37+
)
38+
39+
data WebApiAction (apps :: [Type]) (a :: Type) where
40+
SuccessCall :: WebApiActionCxt apps meth app r => ClientRequest meth (app :// r) -> WebApiAction apps (ApiOut meth (app :// r))
41+
ErrorCall :: WebApiActionCxt apps meth app r => ClientRequest meth (app :// r) -> WebApiAction apps (ApiErr meth (app :// r))
42+
SomeExceptionCall :: WebApiActionCxt apps meth app r => ClientRequest meth (app :// r) -> WebApiAction apps (SomeException)
43+
44+
instance Show (WebApiAction apps a) where
45+
show = \case
46+
SuccessCall creq -> show . toWaiRequest . fromClientRequest $ creq
47+
ErrorCall creq -> show . toWaiRequest . fromClientRequest $ creq
48+
SomeExceptionCall creq -> show . toWaiRequest . fromClientRequest $ creq
49+
50+
-- TODO: Revisit
51+
instance Eq (WebApiAction apps a) where
52+
(==) (SuccessCall creq1) = \case
53+
SuccessCall creq2 -> (show . toWaiRequest . fromClientRequest $ creq1) == (show . toWaiRequest . fromClientRequest $ creq2)
54+
_ -> False
55+
(==) (ErrorCall creq1) = \case
56+
ErrorCall creq2 -> (show . toWaiRequest . fromClientRequest $ creq1) == (show . toWaiRequest . fromClientRequest $ creq2)
57+
_ -> False
58+
(==) (SomeExceptionCall creq1) = \case
59+
SomeExceptionCall creq2 -> (show . toWaiRequest . fromClientRequest $ creq1) == (show . toWaiRequest . fromClientRequest $ creq2)
60+
_ -> False
61+
62+
instance HasVariables (WebApiAction apps a) where
63+
getAllVariables = mempty
64+
65+
data ApiState (apps :: [Type]) = ApiState
66+
deriving (Show, Eq)
67+
68+
instance HasVariables (ApiState apps) where
69+
getAllVariables = mempty
70+
71+
mkWebApiAction :: WebApiAction apps a -> Action (ApiState apps) a
72+
mkWebApiAction = coerce
73+
74+
instance StateModel (ApiState apps) where
75+
newtype Action (ApiState apps) a = MkWebApiAction (WebApiAction apps a)
76+
deriving newtype (Show, Eq, HasVariables)
77+
78+
actionName = \case
79+
MkWebApiAction (SuccessCall creq) -> getOpIdFromRequest creq
80+
MkWebApiAction (ErrorCall creq) -> getOpIdFromRequest creq
81+
MkWebApiAction (SomeExceptionCall creq) -> getOpIdFromRequest creq
82+
83+
arbitraryAction = undefined
84+
initialState = undefined
85+
86+
instance RunModel (ApiState apps) (WebApiSessions apps) where
87+
perform _ act _ = case act of
88+
MkWebApiAction (SuccessCall creq) -> do
89+
testClients creq >>= \case
90+
Success _ out _ _ -> pure out
91+
_ -> error "Fail"
92+
MkWebApiAction (ErrorCall creq) -> do
93+
testClients creq >>= \case
94+
Failure (Left (ApiError _ err _ _)) -> pure err
95+
_ -> error "Fail"
96+
MkWebApiAction (SomeExceptionCall creq) -> do
97+
testClients creq >>= \case
98+
Failure (Right (OtherError e)) -> pure e
99+
_ -> error "Fail"
100+
101+
instance DynLogicModel (ApiState apps) where
102+
restricted _ = False
103+
104+
getOpIdFromRequest :: forall meth app r. (KnownSymbol (GetOpIdName (OperationId meth (app://r))), Typeable app, Typeable r) => ClientRequest meth (app://r) -> String
105+
getOpIdFromRequest _ =
106+
let
107+
routeName = symbolVal (Proxy @(GetOpIdName (OperationId meth (app://r))))
108+
appName = show $ typeRep (Proxy @app)
109+
in appName ++ "/" ++ routeName
110+
111+
type family GetOpIdName (oid :: OpId) :: Symbol where
112+
GetOpIdName ('OpId _ n) = n
113+
GetOpIdName ('UndefinedOpId m r) = TypeError ('Text "OperationId is not set for " ':<>: 'ShowType m ':<>: 'Text " " ':<>: 'ShowType r)

0 commit comments

Comments
 (0)