109 lines
3.1 KiB
Haskell
109 lines
3.1 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module FoundationSpec where
|
|
|
|
import TestImport
|
|
|
|
import ModelSpec ()
|
|
|
|
import Yesod.EmbeddedStatic
|
|
|
|
import Servant.QuickCheck.Internal.HasGenRequest (HasGenRequest(..))
|
|
import qualified Network.HTTP.Client as HTTP
|
|
import qualified Network.HTTP.Types.URI as URI
|
|
|
|
import Yesod.Servant (HasRoute(..), ServantApi, ServantApiUnproxy')
|
|
|
|
import Foundation.ServantSpec ()
|
|
import ServantApi.ExternalApis.TypeSpec ()
|
|
|
|
|
|
instance Arbitrary (Route Auth) where
|
|
arbitrary = oneof
|
|
[ return CheckR
|
|
, return LoginR
|
|
, return LogoutR
|
|
, PluginR <$> arbitrary <*> arbitrary
|
|
]
|
|
|
|
instance Arbitrary (Route EmbeddedStatic) where
|
|
arbitrary = do
|
|
let printableText = pack . filter (/= '/') . getPrintableString <$> arbitrary
|
|
printableText' = printableText `suchThat` (not . null)
|
|
pathLength <- getPositive <$> arbitrary
|
|
path <- replicateM pathLength printableText'
|
|
paramNum <- getNonNegative <$> arbitrary
|
|
params <- replicateM paramNum $ (,) <$> printableText' <*> printableText
|
|
return $ embeddedResourceR path params
|
|
|
|
instance (HasRoute (ServantApiUnproxy' api), HasGenRequest (ServantApiUnproxy' api)) => Arbitrary (Route (ServantApi api)) where
|
|
arbitrary = do
|
|
genReq <- view _2 . genRequest $ Proxy @(ServantApiUnproxy' api)
|
|
let req = genReq $ BaseUrl Http "" 0 ""
|
|
p = filter (not . null) . URI.decodePathSegments $ HTTP.path req
|
|
qs = over (traverse . _2) (fromMaybe mempty) . URI.parseQueryText $ HTTP.queryString req
|
|
maybe (error $ "Could not parse generated servant route: " <> show (p, qs)) return $ parseServantRoute (p, qs)
|
|
|
|
|
|
instance Arbitrary WellKnownFileName where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary SchoolR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary CourseR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary SheetR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary SubmissionR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary MaterialR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary TutorialR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary ExamR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary ExamOfficeR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary EExamR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary CourseNewsR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary CourseEventR where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
instance Arbitrary (Route UniWorX) where
|
|
arbitrary = genericArbitrary
|
|
shrink = genericShrink
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
parallel $
|
|
lawsCheckHspec (Proxy @(Route UniWorX))
|
|
[ eqLaws, hashableLaws, jsonLaws, jsonKeyLaws, pathPieceLaws ]
|