{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module SAML2.WebSSO.Test.Arbitrary where

import Control.Lens
import Data.CaseInsensitive qualified as CI
import Data.Fixed
import Data.List.NonEmpty as NL
import Data.Map qualified as Map
import Data.Proxy
import Data.String.Conversions
import Data.Text qualified as ST
import Data.Time
import Data.UUID qualified as UUID
import Data.X509 qualified as X509
import GHC.Stack
import GHC.TypeLits
import Hedgehog
import Hedgehog.Gen qualified as Gen
import Hedgehog.Gen.QuickCheck qualified as THQ
import Hedgehog.Range qualified as Range
import SAML2.WebSSO
import SAML2.WebSSO.Types.Email qualified as Email
import Servant.Multipart
import Test.QuickCheck (Arbitrary (arbitrary, shrink))
import Test.QuickCheck.Hedgehog qualified as TQH
import Test.QuickCheck.Instances ()
import Text.XML
import Text.XML.DSig qualified as DSig
import URI.ByteString
import Web.Cookie

genHttps :: Gen URI
genHttps :: Gen URI
genHttps = Maybe (Range Int) -> Gen URI
genHttps' Maybe (Range Int)
forall a. Maybe a
Nothing

-- | arbitrary 'URI' with restricted length.
--
-- uri-bytestring has Arbitrary instances, but they are likely to remain internal.  also we're not
-- sure what restrictions we'll need to impose on those in roder to get the URIs of the shape
-- required here.  https://github.com/Soostone/uri-bytestring/issues/45
genHttps' :: Maybe (Range Int) -> Gen URI
genHttps' :: Maybe (Range Int) -> Gen URI
genHttps' Maybe (Range Int)
glen = do
  domain <- Text -> [Text] -> Text
ST.intercalate Text
"." ([Text] -> Text) -> GenT Identity [Text] -> GenT Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> GenT Identity Text -> GenT Identity [Text]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
2 Int
5) GenT Identity Text
genNiceWord
  path <- ST.intercalate "/" <$> Gen.list (Range.linear 0 5) genNiceWord
  mMaxLen :: Maybe Int <- maybe (pure Nothing) (fmap Just . Gen.integral_) glen
  let uri = (Text -> Text)
-> (Int -> Text -> Text) -> Maybe Int -> Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text -> Text
forall a. a -> a
id Int -> Text -> Text
ST.take Maybe Int
mMaxLen (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
domain Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path
  either (error . show) pure $ parseURI' uri

-- | pick N words from a dictionary of popular estonian first names.  this should yield enough
-- entropy, but is much nicer to read.
--
-- (quickcheck has something like this as well.)
genNiceText :: Range Int -> Gen ST
genNiceText :: Range Int -> GenT Identity Text
genNiceText Range Int
rng = [Text] -> Text
ST.unwords ([Text] -> Text) -> GenT Identity [Text] -> GenT Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> GenT Identity Text -> GenT Identity [Text]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list Range Int
rng GenT Identity Text
forall {m :: * -> *} {a}. (MonadGen m, IsString a) => m a
word
  where
    -- popular estonian first names.
    word :: m a
word =
      [a] -> m a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadGen m) =>
f a -> m a
Gen.element
        [ a
"aiandama",
          a
"aitama",
          a
"aitamah",
          a
"aleksander",
          a
"andres",
          a
"andrus",
          a
"anu",
          a
"arri",
          a
"aruka",
          a
"aytama",
          a
"aytamah",
          a
"betti",
          a
"daggi",
          a
"dagi",
          a
"dagmara",
          a
"diana",
          a
"edenema",
          a
"eduk",
          a
"eliisabet",
          a
"elisabet",
          a
"elsbet",
          a
"elts",
          a
"etti",
          a
"etty",
          a
"hele",
          a
"hendrik",
          a
"jaak",
          a
"juku",
          a
"juri",
          a
"kaisa",
          a
"kaja",
          a
"katariina",
          a
"koit",
          a
"leena",
          a
"lenni",
          a
"liisi",
          a
"lilli",
          a
"loviise",
          a
"maarja",
          a
"marika",
          a
"nikolai",
          a
"rina",
          a
"sandra",
          a
"sula",
          a
"taevas",
          a
"taniel",
          a
"tonis",
          a
"ulli",
          a
"urmi",
          a
"vicenc",
          a
"anna",
          a
"eluta",
          a
"hillar",
          a
"jaagup",
          a
"jaan",
          a
"janek",
          a
"jannis",
          a
"jens",
          a
"johan",
          a
"johanna",
          a
"juhan",
          a
"katharina",
          a
"kati",
          a
"katja",
          a
"krista",
          a
"kristian",
          a
"kristina",
          a
"kristjan",
          a
"krists",
          a
"laura",
          a
"leks",
          a
"liisa",
          a
"marga",
          a
"margarete",
          a
"mari",
          a
"maria",
          a
"marye",
          a
"mati",
          a
"matt",
          a
"mihkel",
          a
"mikk",
          a
"olli",
          a
"olly",
          a
"peet",
          a
"peeter",
          a
"pinja",
          a
"reet",
          a
"riki",
          a
"riks",
          a
"rolli",
          a
"toomas"
        ]

genNiceWord :: Gen ST
genNiceWord :: GenT Identity Text
genNiceWord = Range Int -> GenT Identity Text
genNiceText (Int -> Range Int
forall a. a -> Range a
Range.singleton Int
1)

genConfig :: Gen Config
genConfig :: Gen Config
genConfig = do
  _cfgLogLevel <- GenT Identity Level
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded
  _cfgSPHost <- cs <$> genNiceWord
  _cfgSPPort <- Gen.int (Range.linear 1 9999)
  _cfgDomainConfigs <- Left <$> genMultiIngressDomainConfig
  pure Config {..}

genMultiIngressDomainConfig :: Gen MultiIngressDomainConfig
genMultiIngressDomainConfig :: GenT Identity MultiIngressDomainConfig
genMultiIngressDomainConfig = do
  _cfgSPAppURI <- Gen URI
genHttps
  _cfgSPSsoURI <- genHttps
  _cfgContacts <- Gen.list (Range.linear 0 3) genSPContactPerson
  pure MultiIngressDomainConfig {..}

genSPContactPerson :: Gen ContactPerson
genSPContactPerson :: GenT Identity ContactPerson
genSPContactPerson =
  ContactType
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe URI
-> Maybe Text
-> ContactPerson
ContactPerson
    (ContactType
 -> Maybe Text
 -> Maybe Text
 -> Maybe Text
 -> Maybe URI
 -> Maybe Text
 -> ContactPerson)
-> GenT Identity ContactType
-> GenT
     Identity
     (Maybe Text
      -> Maybe Text
      -> Maybe Text
      -> Maybe URI
      -> Maybe Text
      -> ContactPerson)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity ContactType
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded
    GenT
  Identity
  (Maybe Text
   -> Maybe Text
   -> Maybe Text
   -> Maybe URI
   -> Maybe Text
   -> ContactPerson)
-> GenT Identity (Maybe Text)
-> GenT
     Identity
     (Maybe Text
      -> Maybe Text -> Maybe URI -> Maybe Text -> ContactPerson)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Text -> GenT Identity (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Text
genNiceWord
    GenT
  Identity
  (Maybe Text
   -> Maybe Text -> Maybe URI -> Maybe Text -> ContactPerson)
-> GenT Identity (Maybe Text)
-> GenT
     Identity (Maybe Text -> Maybe URI -> Maybe Text -> ContactPerson)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Text -> GenT Identity (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Text
genNiceWord
    GenT
  Identity (Maybe Text -> Maybe URI -> Maybe Text -> ContactPerson)
-> GenT Identity (Maybe Text)
-> GenT Identity (Maybe URI -> Maybe Text -> ContactPerson)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Text -> GenT Identity (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Text
genNiceWord
    GenT Identity (Maybe URI -> Maybe Text -> ContactPerson)
-> GenT Identity (Maybe URI)
-> GenT Identity (Maybe Text -> ContactPerson)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen URI -> GenT Identity (Maybe URI)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe Gen URI
genHttps
    GenT Identity (Maybe Text -> ContactPerson)
-> GenT Identity (Maybe Text) -> GenT Identity ContactPerson
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Text -> GenT Identity (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Text
genNiceWord

genIdPMetadata :: Gen IdPMetadata
genIdPMetadata :: Gen IdPMetadata
genIdPMetadata =
  Issuer -> URI -> NonEmpty SignedCertificate -> IdPMetadata
IdPMetadata
    (Issuer -> URI -> NonEmpty SignedCertificate -> IdPMetadata)
-> GenT Identity Issuer
-> GenT Identity (URI -> NonEmpty SignedCertificate -> IdPMetadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Issuer
genIssuer
    GenT Identity (URI -> NonEmpty SignedCertificate -> IdPMetadata)
-> Gen URI
-> GenT Identity (NonEmpty SignedCertificate -> IdPMetadata)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen URI
genHttps
    GenT Identity (NonEmpty SignedCertificate -> IdPMetadata)
-> GenT Identity (NonEmpty SignedCertificate) -> Gen IdPMetadata
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([SignedCertificate] -> NonEmpty SignedCertificate
forall a. HasCallStack => [a] -> NonEmpty a
NL.fromList ([SignedCertificate] -> NonEmpty SignedCertificate)
-> GenT Identity [SignedCertificate]
-> GenT Identity (NonEmpty SignedCertificate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int
-> GenT Identity SignedCertificate
-> GenT Identity [SignedCertificate]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
3) GenT Identity SignedCertificate
genX509SignedCertificate)

-- FUTUREWORK: we can do better than constant here...
genX509SignedCertificate :: Gen X509.SignedCertificate
genX509SignedCertificate :: GenT Identity SignedCertificate
genX509SignedCertificate = (String -> GenT Identity SignedCertificate)
-> (SignedCertificate -> GenT Identity SignedCertificate)
-> Either String SignedCertificate
-> GenT Identity SignedCertificate
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> GenT Identity SignedCertificate
forall a. HasCallStack => String -> a
error (String -> GenT Identity SignedCertificate)
-> (String -> String) -> String -> GenT Identity SignedCertificate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) SignedCertificate -> GenT Identity SignedCertificate
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String SignedCertificate
 -> GenT Identity SignedCertificate)
-> Either String SignedCertificate
-> GenT Identity SignedCertificate
forall a b. (a -> b) -> a -> b
$ Bool -> LT -> Either String SignedCertificate
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Bool -> LT -> m SignedCertificate
DSig.parseKeyInfo Bool
False LT
"<KeyInfo xmlns=\"http://www.w3.org/2000/09/xmldsig#\"><X509Data><X509Certificate>MIIDBTCCAe2gAwIBAgIQev76BWqjWZxChmKkGqoAfDANBgkqhkiG9w0BAQsFADAtMSswKQYDVQQDEyJhY2NvdW50cy5hY2Nlc3Njb250cm9sLndpbmRvd3MubmV0MB4XDTE4MDIxODAwMDAwMFoXDTIwMDIxOTAwMDAwMFowLTErMCkGA1UEAxMiYWNjb3VudHMuYWNjZXNzY29udHJvbC53aW5kb3dzLm5ldDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAMgmGiRfLh6Fdi99XI2VA3XKHStWNRLEy5Aw/gxFxchnh2kPdk/bejFOs2swcx7yUWqxujjCNRsLBcWfaKUlTnrkY7i9x9noZlMrijgJy/Lk+HH5HX24PQCDf+twjnHHxZ9G6/8VLM2e5ZBeZm+t7M3vhuumEHG3UwloLF6cUeuPdW+exnOB1U1fHBIFOG8ns4SSIoq6zw5rdt0CSI6+l7b1DEjVvPLtJF+zyjlJ1Qp7NgBvAwdiPiRMU4l8IRVbuSVKoKYJoyJ4L3eXsjczoBSTJ6VjV2mygz96DC70MY3avccFrk7tCEC6ZlMRBfY1XPLyldT7tsR3EuzjecSa1M8CAwEAAaMhMB8wHQYDVR0OBBYEFIks1srixjpSLXeiR8zES5cTY6fBMA0GCSqGSIb3DQEBCwUAA4IBAQCKthfK4C31DMuDyQZVS3F7+4Evld3hjiwqu2uGDK+qFZas/D/eDunxsFpiwqC01RIMFFN8yvmMjHphLHiBHWxcBTS+tm7AhmAvWMdxO5lzJLS+UWAyPF5ICROe8Mu9iNJiO5JlCo0Wpui9RbB1C81Xhax1gWHK245ESL6k7YWvyMYWrGqr1NuQcNS0B/AIT1Nsj1WY7efMJQOmnMHkPUTWryVZlthijYyd7P2Gz6rY5a81DAFqhDNJl2pGIAE6HWtSzeUEh3jCsHEkoglKfm4VrGJEuXcALmfCMbdfTvtu4rlsaP2hQad+MG/KJFlenoTK34EMHeBPDCpqNDz8UVNk</X509Certificate></X509Data></KeyInfo>"

genSPMetadata :: Gen SPMetadata
genSPMetadata :: Gen SPMetadata
genSPMetadata = do
  _spID <- Gen (ID SPMetadata)
forall {k} (a :: k). Gen (ID a)
genID
  _spValidUntil <- fromTime <$> genTime
  _spCacheDuration <- genNominalDifftime
  _spOrgName <- genNiceWord
  _spOrgDisplayName <- genNiceWord
  _spOrgURL <- genHttps
  _spResponseURL <- genHttps
  _spContacts <- Gen.list (Range.linear 0 3) genContactPerson
  pure SPMetadata {..}

genContactPerson :: Gen ContactPerson
genContactPerson :: GenT Identity ContactPerson
genContactPerson = do
  _cntType <- GenT Identity ContactType
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded
  _cntCompany <- Gen.maybe genNiceWord
  _cntGivenName <- Gen.maybe genNiceWord
  _cntSurname <- Gen.maybe genNiceWord
  _cntEmail <- Gen.maybe genEmailURI
  _cntPhone <- Gen.maybe genNiceWord
  pure ContactPerson {..}

genEmailURI :: Gen URI
genEmailURI :: Gen URI
genEmailURI = do
  loc <- GenT Identity Text
genNiceWord
  pure . unsafeParseURI $ "email:" <> loc <> "@example.com"

genEmail :: (HasCallStack) => Gen (CI.CI Email.Email)
genEmail :: HasCallStack => Gen (CI Email)
genEmail = do
  loc <- GenT Identity Text
genNiceWord
  either (error . ("genEmail: " <>)) pure . Email.validate $ loc <> "@example.com"

genAuthnRequest :: Gen AuthnRequest
genAuthnRequest :: Gen AuthnRequest
genAuthnRequest =
  ID AuthnRequest
-> Time -> Issuer -> Maybe NameIdPolicy -> AuthnRequest
AuthnRequest
    (ID AuthnRequest
 -> Time -> Issuer -> Maybe NameIdPolicy -> AuthnRequest)
-> GenT Identity (ID AuthnRequest)
-> GenT
     Identity (Time -> Issuer -> Maybe NameIdPolicy -> AuthnRequest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity (ID AuthnRequest)
forall {k} (a :: k). Gen (ID a)
genID
    GenT
  Identity (Time -> Issuer -> Maybe NameIdPolicy -> AuthnRequest)
-> GenT Identity Time
-> GenT Identity (Issuer -> Maybe NameIdPolicy -> AuthnRequest)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Time
genTime
    GenT Identity (Issuer -> Maybe NameIdPolicy -> AuthnRequest)
-> GenT Identity Issuer
-> GenT Identity (Maybe NameIdPolicy -> AuthnRequest)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Issuer
genIssuer
    GenT Identity (Maybe NameIdPolicy -> AuthnRequest)
-> GenT Identity (Maybe NameIdPolicy) -> Gen AuthnRequest
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity NameIdPolicy -> GenT Identity (Maybe NameIdPolicy)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity NameIdPolicy
genNameIDPolicy

-- | (we only allow full microseconds, since someone, somewhere does the rounding for us in the
-- tests if we don't do it here, which makes the affected tests fail.)
genTime :: Gen Time
genTime :: GenT Identity Time
genTime = UTCTime -> Time
Time (UTCTime -> Time) -> (UTCTime -> UTCTime) -> UTCTime -> Time
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> UTCTime
picoToMicro (UTCTime -> Time) -> GenT Identity UTCTime -> GenT Identity Time
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen UTCTime -> GenT Identity UTCTime
forall (m :: * -> *) a. MonadGen m => Gen a -> m a
THQ.quickcheck Gen UTCTime
forall a. Arbitrary a => Gen a
arbitrary
  where
    picoToMicro :: UTCTime -> UTCTime
picoToMicro = (Pico -> Identity Pico) -> UTCTime -> Identity UTCTime
Lens' UTCTime Pico
seconds ((Pico -> Identity Pico) -> UTCTime -> Identity UTCTime)
-> (Pico -> Pico) -> UTCTime -> UTCTime
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* (Pico
1000 Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
1000)) (Pico -> Pico) -> (Pico -> Pico) -> Pico -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pico -> Pico -> Pico
forall a. Fractional a => a -> a -> a
/ (Pico
1000 Pico -> Pico -> Pico
forall a. Num a => a -> a -> a
* Pico
1000)))

genDuration :: Gen Duration
genDuration :: Gen Duration
genDuration = Duration -> Gen Duration
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Duration
Duration

genNominalDifftime :: Gen NominalDiffTime
genNominalDifftime :: Gen NominalDiffTime
genNominalDifftime = Gen NominalDiffTime -> Gen NominalDiffTime
forall (m :: * -> *) a. MonadGen m => Gen a -> m a
THQ.quickcheck Gen NominalDiffTime
forall a. Arbitrary a => Gen a
arbitrary

genID :: Gen (ID a)
genID :: forall {k} (a :: k). Gen (ID a)
genID = Text -> ID a
forall {k} (m :: k). Text -> ID m
ID (Text -> ID a) -> (UUID -> Text) -> UUID -> ID a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (UUID -> Text) -> UUID -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> Text
UUID.toText (UUID -> ID a) -> GenT Identity UUID -> GenT Identity (ID a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity UUID
HasCallStack => GenT Identity UUID
genUUID

genIssuer :: Gen Issuer
genIssuer :: GenT Identity Issuer
genIssuer = URI -> Issuer
Issuer (URI -> Issuer) -> Gen URI -> GenT Identity Issuer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen URI
genHttps

genNameIDPolicy :: Gen NameIdPolicy
genNameIDPolicy :: GenT Identity NameIdPolicy
genNameIDPolicy =
  NameIDFormat -> Maybe Text -> Bool -> NameIdPolicy
NameIdPolicy
    (NameIDFormat -> Maybe Text -> Bool -> NameIdPolicy)
-> GenT Identity NameIDFormat
-> GenT Identity (Maybe Text -> Bool -> NameIdPolicy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity NameIDFormat
genNameIDFormat
    GenT Identity (Maybe Text -> Bool -> NameIdPolicy)
-> GenT Identity (Maybe Text)
-> GenT Identity (Bool -> NameIdPolicy)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Text -> GenT Identity (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Text
genNiceWord
    GenT Identity (Bool -> NameIdPolicy)
-> GenT Identity Bool -> GenT Identity NameIdPolicy
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Bool
forall (m :: * -> *). MonadGen m => m Bool
Gen.bool

genNameIDFormat :: Gen NameIDFormat
genNameIDFormat :: GenT Identity NameIDFormat
genNameIDFormat = GenT Identity NameIDFormat
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded

genNameID :: Gen NameID
genNameID :: Gen NameID
genNameID = do
  unid <- Gen UnqualifiedNameID
genUnqualifiedNameID
  case unid of
    UNameIDEntity URI
enturi -> NameID -> Gen NameID
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NameID -> Gen NameID) -> NameID -> Gen NameID
forall a b. (a -> b) -> a -> b
$ URI -> NameID
entityNameID URI
enturi
    UnqualifiedNameID
_ ->
      (String -> Gen NameID)
-> (NameID -> Gen NameID) -> Either String NameID -> Gen NameID
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Gen NameID
forall a. HasCallStack => String -> a
error (String -> Gen NameID)
-> (String -> String) -> String -> Gen NameID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) NameID -> Gen NameID
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Either String NameID -> Gen NameID)
-> GenT Identity (Either String NameID) -> Gen NameID
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (UnqualifiedNameID
-> Maybe Text -> Maybe Text -> Maybe Text -> Either String NameID
forall (m :: * -> *).
MonadError String m =>
UnqualifiedNameID
-> Maybe Text -> Maybe Text -> Maybe Text -> m NameID
mkNameID UnqualifiedNameID
unid (Maybe Text -> Maybe Text -> Maybe Text -> Either String NameID)
-> GenT Identity (Maybe Text)
-> GenT Identity (Maybe Text -> Maybe Text -> Either String NameID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity (Maybe Text)
qualifier GenT Identity (Maybe Text -> Maybe Text -> Either String NameID)
-> GenT Identity (Maybe Text)
-> GenT Identity (Maybe Text -> Either String NameID)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity (Maybe Text)
qualifier GenT Identity (Maybe Text -> Either String NameID)
-> GenT Identity (Maybe Text)
-> GenT Identity (Either String NameID)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity (Maybe Text)
qualifier)
  where
    qualifier :: GenT Identity (Maybe Text)
qualifier = GenT Identity Text -> GenT Identity (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (GenT Identity Text -> GenT Identity (Maybe Text))
-> (Range Int -> GenT Identity Text)
-> Range Int
-> GenT Identity (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range Int -> GenT Identity Text
genNiceText (Range Int -> GenT Identity (Maybe Text))
-> Range Int -> GenT Identity (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.exponential Int
1 Int
100

genUnqualifiedNameID :: Gen UnqualifiedNameID
genUnqualifiedNameID :: Gen UnqualifiedNameID
genUnqualifiedNameID =
  [Gen UnqualifiedNameID] -> Gen UnqualifiedNameID
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
    [ Text -> UnqualifiedNameID
UNameIDUnspecified (Text -> UnqualifiedNameID)
-> GenT Identity Text -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity Text
forall {m :: * -> *}. MonadGen m => Int -> m Text
mktxt Int
2000,
      CI Email -> UnqualifiedNameID
UNameIDEmail (CI Email -> UnqualifiedNameID)
-> Gen (CI Email) -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (CI Email)
HasCallStack => Gen (CI Email)
genEmail,
      Text -> UnqualifiedNameID
UNameIDX509 (Text -> UnqualifiedNameID)
-> GenT Identity Text -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity Text
forall {m :: * -> *}. MonadGen m => Int -> m Text
mktxt Int
2000,
      Text -> UnqualifiedNameID
UNameIDWindows (Text -> UnqualifiedNameID)
-> GenT Identity Text -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity Text
forall {m :: * -> *}. MonadGen m => Int -> m Text
mktxt Int
2000,
      Text -> UnqualifiedNameID
UNameIDKerberos (Text -> UnqualifiedNameID)
-> GenT Identity Text -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity Text
forall {m :: * -> *}. MonadGen m => Int -> m Text
mktxt Int
2000,
      URI -> UnqualifiedNameID
UNameIDEntity (URI -> UnqualifiedNameID) -> Gen URI -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Range Int) -> Gen URI
genHttps' (Range Int -> Maybe (Range Int)
forall a. a -> Maybe a
Just (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
12 Int
1024)),
      Text -> UnqualifiedNameID
UNameIDPersistent (Text -> UnqualifiedNameID)
-> GenT Identity Text -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity Text
forall {m :: * -> *}. MonadGen m => Int -> m Text
mktxt Int
1024,
      Text -> UnqualifiedNameID
UNameIDTransient (Text -> UnqualifiedNameID)
-> GenT Identity Text -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity Text
forall {m :: * -> *}. MonadGen m => Int -> m Text
mktxt Int
2000
    ]
  where
    mktxt :: Int -> m Text
mktxt Int
charlen = Range Int -> m Char -> m Text
forall (m :: * -> *). MonadGen m => Range Int -> m Char -> m Text
Gen.text (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
charlen) m Char
forall (m :: * -> *). MonadGen m => m Char
Gen.alpha

genNonEmpty :: Range Int -> Gen a -> Gen (NonEmpty a)
genNonEmpty :: forall a. Range Int -> Gen a -> Gen (NonEmpty a)
genNonEmpty Range Int
rng Gen a
gen = a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> NonEmpty a)
-> Gen a -> GenT Identity ([a] -> NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
gen GenT Identity ([a] -> NonEmpty a)
-> GenT Identity [a] -> GenT Identity (NonEmpty a)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> Gen a -> GenT Identity [a]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list Range Int
rng Gen a
gen

genStatus :: Gen Status
genStatus :: Gen Status
genStatus = Gen Status
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded

genAuthnResponse :: Gen AuthnResponse
genAuthnResponse :: Gen AuthnResponse
genAuthnResponse = Gen (NonEmpty Assertion) -> Gen AuthnResponse
forall payload. Gen payload -> Gen (Response payload)
genResponse ([Assertion] -> NonEmpty Assertion
forall a. HasCallStack => [a] -> NonEmpty a
NL.fromList ([Assertion] -> NonEmpty Assertion)
-> GenT Identity [Assertion] -> Gen (NonEmpty Assertion)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> GenT Identity Assertion -> GenT Identity [Assertion]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
3) GenT Identity Assertion
genAssertion)

genResponse :: forall payload. Gen payload -> Gen (Response payload)
genResponse :: forall payload. Gen payload -> Gen (Response payload)
genResponse Gen payload
genPayload = do
  _rspID <- Gen (ID (Response payload))
forall {k} (a :: k). Gen (ID a)
genID
  _rspInRespTo <- Gen.maybe genID
  _rspIssueInstant <- genTime
  _rspDestination <- Gen.maybe genHttps
  _rspIssuer <- Gen.maybe genIssuer
  _rspStatus <- genStatus
  _rspPayload <- Gen.small genPayload
  pure Response {..}

genAssertion :: Gen Assertion
genAssertion :: GenT Identity Assertion
genAssertion = do
  _assID <- Gen (ID Assertion)
forall {k} (a :: k). Gen (ID a)
genID
  _assIssueInstant <- genTime
  _assIssuer <- genIssuer
  _assConditions <- Gen.maybe genConditions
  _assContents <- genSubjectAndStatements
  pure Assertion {..}

genConditions :: Gen Conditions
genConditions :: GenT Identity Conditions
genConditions =
  Maybe Time -> Maybe Time -> Bool -> [NonEmpty URI] -> Conditions
Conditions
    (Maybe Time -> Maybe Time -> Bool -> [NonEmpty URI] -> Conditions)
-> GenT Identity (Maybe Time)
-> GenT
     Identity (Maybe Time -> Bool -> [NonEmpty URI] -> Conditions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Time -> GenT Identity (Maybe Time)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Time
genTime
    GenT Identity (Maybe Time -> Bool -> [NonEmpty URI] -> Conditions)
-> GenT Identity (Maybe Time)
-> GenT Identity (Bool -> [NonEmpty URI] -> Conditions)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Time -> GenT Identity (Maybe Time)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Time
genTime
    GenT Identity (Bool -> [NonEmpty URI] -> Conditions)
-> GenT Identity Bool
-> GenT Identity ([NonEmpty URI] -> Conditions)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Bool
forall (m :: * -> *). MonadGen m => m Bool
Gen.bool
    GenT Identity ([NonEmpty URI] -> Conditions)
-> GenT Identity [NonEmpty URI] -> GenT Identity Conditions
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int
-> GenT Identity (NonEmpty URI) -> GenT Identity [NonEmpty URI]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
3) (Range Int -> Gen URI -> GenT Identity (NonEmpty URI)
forall a. Range Int -> Gen a -> Gen (NonEmpty a)
genNonEmpty (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
3) Gen URI
genHttps)

genSubjectAndStatements :: Gen SubjectAndStatements
genSubjectAndStatements :: Gen SubjectAndStatements
genSubjectAndStatements =
  Subject -> NonEmpty Statement -> SubjectAndStatements
SubjectAndStatements
    (Subject -> NonEmpty Statement -> SubjectAndStatements)
-> GenT Identity Subject
-> GenT Identity (NonEmpty Statement -> SubjectAndStatements)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Subject
genSubject
    GenT Identity (NonEmpty Statement -> SubjectAndStatements)
-> GenT Identity (NonEmpty Statement) -> Gen SubjectAndStatements
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> Gen Statement -> GenT Identity (NonEmpty Statement)
forall a. Range Int -> Gen a -> Gen (NonEmpty a)
genNonEmpty (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
3) Gen Statement
genStatement

genSubject :: Gen Subject
genSubject :: GenT Identity Subject
genSubject =
  NameID -> [SubjectConfirmation] -> Subject
Subject
    (NameID -> [SubjectConfirmation] -> Subject)
-> Gen NameID -> GenT Identity ([SubjectConfirmation] -> Subject)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen NameID
genNameID
    GenT Identity ([SubjectConfirmation] -> Subject)
-> GenT Identity [SubjectConfirmation] -> GenT Identity Subject
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int
-> GenT Identity SubjectConfirmation
-> GenT Identity [SubjectConfirmation]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
8) GenT Identity SubjectConfirmation
genSubjectConfirmation

genSubjectConfirmation :: Gen SubjectConfirmation
genSubjectConfirmation :: GenT Identity SubjectConfirmation
genSubjectConfirmation =
  SubjectConfirmationMethod
-> Maybe SubjectConfirmationData -> SubjectConfirmation
SubjectConfirmation
    (SubjectConfirmationMethod
 -> Maybe SubjectConfirmationData -> SubjectConfirmation)
-> GenT Identity SubjectConfirmationMethod
-> GenT
     Identity (Maybe SubjectConfirmationData -> SubjectConfirmation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity SubjectConfirmationMethod
genSubjectConfirmationMethod
    GenT
  Identity (Maybe SubjectConfirmationData -> SubjectConfirmation)
-> GenT Identity (Maybe SubjectConfirmationData)
-> GenT Identity SubjectConfirmation
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity SubjectConfirmationData
-> GenT Identity (Maybe SubjectConfirmationData)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity SubjectConfirmationData
genSubjectConfirmationData

genSubjectConfirmationMethod :: Gen SubjectConfirmationMethod
genSubjectConfirmationMethod :: GenT Identity SubjectConfirmationMethod
genSubjectConfirmationMethod = GenT Identity SubjectConfirmationMethod
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded

genSubjectConfirmationData :: Gen SubjectConfirmationData
genSubjectConfirmationData :: GenT Identity SubjectConfirmationData
genSubjectConfirmationData = do
  _scdNotBefore <- GenT Identity Time -> GenT Identity (Maybe Time)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Time
genTime
  _scdNotOnOrAfter <- genTime
  _scdRecipient <- genHttps
  _scdInResponseTo <- Gen.maybe genID
  _scdAddress <- Gen.maybe genIP
  pure SubjectConfirmationData {..}

genDNSName :: Gen DNSName
genDNSName :: Gen DNSName
genDNSName =
  [Gen DNSName] -> Gen DNSName
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice ([Gen DNSName] -> Gen DNSName) -> [Gen DNSName] -> Gen DNSName
forall a b. (a -> b) -> a -> b
$
    DNSName -> Gen DNSName
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNSName -> Gen DNSName)
-> (Text -> DNSName) -> Text -> Gen DNSName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DNSName
mkDNSName
      (Text -> Gen DNSName) -> [Text] -> [Gen DNSName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Text
"localhost",
            Text
"one.example.com",
            Text
"two.example.com",
            Text
"three.example.com",
            Text
"four.example.com",
            Text
"five.example.com",
            Text
"six.example.com",
            Text
"seven.example.com"
          ]

genIP :: Gen IP
genIP :: GenT Identity IP
genIP =
  [GenT Identity IP] -> GenT Identity IP
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice ([GenT Identity IP] -> GenT Identity IP)
-> [GenT Identity IP] -> GenT Identity IP
forall a b. (a -> b) -> a -> b
$
    (String -> GenT Identity IP)
-> (IP -> GenT Identity IP) -> Either String IP -> GenT Identity IP
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> GenT Identity IP
forall a. HasCallStack => String -> a
error (String -> GenT Identity IP)
-> (String -> String) -> String -> GenT Identity IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) IP -> GenT Identity IP
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Either String IP -> GenT Identity IP)
-> (Text -> Either String IP) -> Text -> GenT Identity IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String IP
forall (m :: * -> *). MonadError String m => Text -> m IP
mkIP
      (Text -> GenT Identity IP) -> [Text] -> [GenT Identity IP]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ Text
"127.0.0.1",
            Text
"::1",
            Text
"192.168.1.0",
            Text
"192.168.1.1",
            Text
"192.168.1.2",
            Text
"192.168.1.3",
            Text
"192.168.1.4",
            Text
"192.168.1.5",
            Text
"192.168.1.6",
            Text
"192.168.1.7",
            Text
"192.168.1.8",
            Text
"192.168.1.9"
          ]

genStatement :: Gen Statement
genStatement :: Gen Statement
genStatement = do
  _astAuthnInstant <- GenT Identity Time
genTime
  _astSessionIndex <- Gen.maybe genNiceWord
  _astSessionNotOnOrAfter <- Gen.maybe genTime
  _astSubjectLocality <- Gen.maybe genLocality
  pure AuthnStatement {..}

genLocality :: Gen Locality
genLocality :: GenT Identity Locality
genLocality =
  Maybe IP -> Maybe DNSName -> Locality
Locality
    (Maybe IP -> Maybe DNSName -> Locality)
-> GenT Identity (Maybe IP)
-> GenT Identity (Maybe DNSName -> Locality)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity IP -> GenT Identity (Maybe IP)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity IP
genIP
    GenT Identity (Maybe DNSName -> Locality)
-> GenT Identity (Maybe DNSName) -> GenT Identity Locality
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen DNSName -> GenT Identity (Maybe DNSName)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe Gen DNSName
genDNSName

genXMLDocument :: Gen Document
genXMLDocument :: Gen Document
genXMLDocument = do
  el <- Gen Element
genXMLElement
  pure $ Document (Prologue [] Nothing []) el []

genXMLNode :: Gen Node
genXMLNode :: Gen Node
genXMLNode =
  [Gen Node] -> Gen Node
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
    [ Element -> Node
NodeElement (Element -> Node) -> Gen Element -> Gen Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Element
genXMLElement,
      Instruction -> Node
NodeInstruction (Instruction -> Node) -> GenT Identity Instruction -> Gen Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Instruction
genXMLInstruction,
      Text -> Node
NodeContent (Text -> Node) -> GenT Identity Text -> Gen Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> GenT Identity Text
genNiceText (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
100),
      Text -> Node
NodeComment (Text -> Node) -> GenT Identity Text -> Gen Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> GenT Identity Text
genNiceText (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
100)
    ]

genXMLElement :: Gen Element
genXMLElement :: Gen Element
genXMLElement =
  Name -> Map Name Text -> [Node] -> Element
Element
    (Name -> Map Name Text -> [Node] -> Element)
-> GenT Identity Name
-> GenT Identity (Map Name Text -> [Node] -> Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Name
genXMLName
    GenT Identity (Map Name Text -> [Node] -> Element)
-> GenT Identity (Map Name Text)
-> GenT Identity ([Node] -> Element)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity (Map Name Text)
genXMLAttrs
    GenT Identity ([Node] -> Element)
-> GenT Identity [Node] -> Gen Element
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Int -> Gen Node -> GenT Identity [Node]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
10) (Gen Node -> Gen Node
forall (m :: * -> *) a. MonadGen m => m a -> m a
Gen.small Gen Node
genXMLNode)

genXMLName :: Gen Name
genXMLName :: GenT Identity Name
genXMLName =
  Text -> Maybe Text -> Maybe Text -> Name
Name
    (Text -> Maybe Text -> Maybe Text -> Name)
-> GenT Identity Text
-> GenT Identity (Maybe Text -> Maybe Text -> Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord
    GenT Identity (Maybe Text -> Maybe Text -> Name)
-> GenT Identity (Maybe Text) -> GenT Identity (Maybe Text -> Name)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Text -> GenT Identity (Maybe Text)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Text
genNiceWord
    GenT Identity (Maybe Text -> Name)
-> GenT Identity (Maybe Text) -> GenT Identity Name
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> GenT Identity (Maybe Text)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing -- @Gen.maybe genNiceWord@, but in documents that use the same prefix for two
    -- different spaces, this breaks the test suite.  (FUTUREWORK: arguably the
    -- parser libraries (either HXT or xml-conduit) should catch this and throw an
    -- error.  current behavior is unspecified result of the name space lookup.)

genXMLAttrs :: Gen (Map.Map Name ST)
genXMLAttrs :: GenT Identity (Map Name Text)
genXMLAttrs = [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Text)] -> Map Name Text)
-> GenT Identity [(Name, Text)] -> GenT Identity (Map Name Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int
-> GenT Identity (Name, Text) -> GenT Identity [(Name, Text)]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
7) GenT Identity (Name, Text)
genXMLAttr

genXMLAttr :: Gen (Name, ST)
genXMLAttr :: GenT Identity (Name, Text)
genXMLAttr = (,) (Name -> Text -> (Name, Text))
-> GenT Identity Name -> GenT Identity (Text -> (Name, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Name
genXMLName GenT Identity (Text -> (Name, Text))
-> GenT Identity Text -> GenT Identity (Name, Text)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Text
genNiceWord

genXMLInstruction :: Gen Instruction
genXMLInstruction :: GenT Identity Instruction
genXMLInstruction = Text -> Text -> Instruction
Instruction (Text -> Text -> Instruction)
-> GenT Identity Text -> GenT Identity (Text -> Instruction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord GenT Identity (Text -> Instruction)
-> GenT Identity Text -> GenT Identity Instruction
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GenT Identity Text
genNiceWord

genUUID :: (HasCallStack) => Gen UUID.UUID
genUUID :: HasCallStack => GenT Identity UUID
genUUID = Gen UUID -> GenT Identity UUID
forall (m :: * -> *) a. MonadGen m => Gen a -> m a
THQ.quickcheck Gen UUID
forall a. Arbitrary a => Gen a
arbitrary

genIdPId :: Gen IdPId
genIdPId :: Gen IdPId
genIdPId = UUID -> IdPId
IdPId (UUID -> IdPId) -> GenT Identity UUID -> Gen IdPId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity UUID
HasCallStack => GenT Identity UUID
genUUID

genSignedCertificate :: Gen X509.SignedCertificate
genSignedCertificate :: GenT Identity SignedCertificate
genSignedCertificate =
  (String -> GenT Identity SignedCertificate)
-> (SignedCertificate -> GenT Identity SignedCertificate)
-> Either String SignedCertificate
-> GenT Identity SignedCertificate
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> GenT Identity SignedCertificate
forall a. HasCallStack => String -> a
error (String -> GenT Identity SignedCertificate)
-> (String -> String) -> String -> GenT Identity SignedCertificate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) SignedCertificate -> GenT Identity SignedCertificate
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String SignedCertificate
 -> GenT Identity SignedCertificate)
-> Either String SignedCertificate
-> GenT Identity SignedCertificate
forall a b. (a -> b) -> a -> b
$
    Bool -> LT -> Either String SignedCertificate
forall (m :: * -> *).
(HasCallStack, MonadError String m) =>
Bool -> LT -> m SignedCertificate
DSig.parseKeyInfo
      Bool
False
      LT
"<KeyInfo xmlns=\"http://www.w3.org/2000/09/xmldsig#\"><X509Data><X509Certificate>MIIDBTCCAe2gAwIBAgIQev76BWqjWZxChmKkGqoAfDANBgkqhkiG9w0BAQsFADAtMSswKQYDVQQDEyJhY2NvdW50cy5hY2Nlc3Njb250cm9sLndpbmRvd3MubmV0MB4XDTE4MDIxODAwMDAwMFoXDTIwMDIxOTAwMDAwMFowLTErMCkGA1UEAxMiYWNjb3VudHMuYWNjZXNzY29udHJvbC53aW5kb3dzLm5ldDCCASIwDQYJKoZIhvcNAQEBBQADggEPADCCAQoCggEBAMgmGiRfLh6Fdi99XI2VA3XKHStWNRLEy5Aw/gxFxchnh2kPdk/bejFOs2swcx7yUWqxujjCNRsLBcWfaKUlTnrkY7i9x9noZlMrijgJy/Lk+HH5HX24PQCDf+twjnHHxZ9G6/8VLM2e5ZBeZm+t7M3vhuumEHG3UwloLF6cUeuPdW+exnOB1U1fHBIFOG8ns4SSIoq6zw5rdt0CSI6+l7b1DEjVvPLtJF+zyjlJ1Qp7NgBvAwdiPiRMU4l8IRVbuSVKoKYJoyJ4L3eXsjczoBSTJ6VjV2mygz96DC70MY3avccFrk7tCEC6ZlMRBfY1XPLyldT7tsR3EuzjecSa1M8CAwEAAaMhMB8wHQYDVR0OBBYEFIks1srixjpSLXeiR8zES5cTY6fBMA0GCSqGSIb3DQEBCwUAA4IBAQCKthfK4C31DMuDyQZVS3F7+4Evld3hjiwqu2uGDK+qFZas/D/eDunxsFpiwqC01RIMFFN8yvmMjHphLHiBHWxcBTS+tm7AhmAvWMdxO5lzJLS+UWAyPF5ICROe8Mu9iNJiO5JlCo0Wpui9RbB1C81Xhax1gWHK245ESL6k7YWvyMYWrGqr1NuQcNS0B/AIT1Nsj1WY7efMJQOmnMHkPUTWryVZlthijYyd7P2Gz6rY5a81DAFqhDNJl2pGIAE6HWtSzeUEh3jCsHEkoglKfm4VrGJEuXcALmfCMbdfTvtu4rlsaP2hQad+MG/KJFlenoTK34EMHeBPDCpqNDz8UVNk</X509Certificate></X509Data></KeyInfo>"

genIdPConfig :: Gen a -> Gen (IdPConfig a)
genIdPConfig :: forall a. Gen a -> Gen (IdPConfig a)
genIdPConfig Gen a
genExtra = do
  _idpId <- Gen IdPId
genIdPId
  _idpMetadataURI <- genHttps
  _idpMetadata <- genIdPMetadata
  _idpExtraInfo <- genExtra
  pure IdPConfig {..}

genFormRedirect :: Gen a -> Gen (FormRedirect a)
genFormRedirect :: forall a. Gen a -> Gen (FormRedirect a)
genFormRedirect Gen a
genBody = URI -> a -> FormRedirect a
forall xml. URI -> xml -> FormRedirect xml
FormRedirect (URI -> a -> FormRedirect a)
-> Gen URI -> GenT Identity (a -> FormRedirect a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen URI
genHttps GenT Identity (a -> FormRedirect a)
-> Gen a -> GenT Identity (FormRedirect a)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen a
genBody

genSimpleSetCookie :: forall (name :: Symbol). (KnownSymbol name) => Gen (SimpleSetCookie name)
genSimpleSetCookie :: forall (name :: Symbol).
KnownSymbol name =>
Gen (SimpleSetCookie name)
genSimpleSetCookie = do
  val <- Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString)
-> GenT Identity Text -> GenT Identity ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord
  path <-
    Gen.choice
      [ Just . cs . ST.intercalate "/" <$> Gen.list (Range.linear 0 3) genNiceWord,
        pure $ Just "/",
        pure Nothing
      ]
  expires <- Gen.maybe (THQ.quickcheck arbitrary <&> seconds %~ (* 10e12) . (/ 10e12)) -- only full seconds
  maxage <- Gen.maybe $ fromIntegral <$> Gen.int (Range.linear 0 1000) -- only non-negative, full seconds
  domain <- Gen.maybe (cs . ST.intercalate "." <$> Gen.list (Range.linear 2 3) genNiceWord)
  httponly <- Gen.bool
  secure <- Gen.bool
  samesite <- Gen.maybe $ Gen.element [sameSiteLax, sameSiteStrict]
  pure . SimpleSetCookie $
    def
      { setCookieName = cookieName (Proxy @name),
        setCookieValue = val,
        setCookiePath = path,
        setCookieExpires = expires,
        setCookieMaxAge = maxage,
        setCookieDomain = domain,
        setCookieHttpOnly = httponly,
        setCookieSecure = secure,
        setCookieSameSite = samesite
      }

{-
-- FUTUREWORK: this would be much more possible to implement if 'AuthnResponseBody' would be
-- defined with type parameters rather than existentially quantified types in
-- 'authnResponseBodyAction'.)
genAuthnResponseBody :: Gen AuthnResponseBody
genAuthnResponseBody = do
  aresp <- genAuthnResponse
  idp <- genIdPConfig (pure ())
  raw <- genRawAuthnResponseBody
  pure (AuthnResponseBody (\_ -> pure (aresp, idp)) raw)
-}

genRawAuthnResponseBody :: Gen (MultipartData Mem)
genRawAuthnResponseBody :: Gen (MultipartData Mem)
genRawAuthnResponseBody = do
  raw <- Range Int -> GenT Identity Char -> GenT Identity Text
forall (m :: * -> *). MonadGen m => Range Int -> m Char -> m Text
Gen.text (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
50 Int
100) GenT Identity Char
forall (m :: * -> *). MonadGen m => m Char
Gen.ascii
  pure MultipartData {files = [], inputs = [Input {iName = "SAMLResponse", iValue = raw}]}

-- FUTUREWORK: the following could be TH-generated entirely (take all declarations matching '^gen' and
-- turn the resp. types into Arbitrary instances).

instance Arbitrary UserRef where
  arbitrary :: Gen UserRef
arbitrary = Issuer -> NameID -> UserRef
UserRef (Issuer -> NameID -> UserRef)
-> Gen Issuer -> Gen (NameID -> UserRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Issuer
forall a. Arbitrary a => Gen a
arbitrary Gen (NameID -> UserRef) -> Gen NameID -> Gen UserRef
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen NameID
forall a. Arbitrary a => Gen a
arbitrary

instance Arbitrary (MultipartData Mem) where
  arbitrary :: Gen (MultipartData Mem)
arbitrary = Gen (MultipartData Mem) -> Gen (MultipartData Mem)
forall a. Gen a -> Gen a
TQH.hedgehog Gen (MultipartData Mem)
genRawAuthnResponseBody

instance Arbitrary Assertion where
  arbitrary :: Gen Assertion
arbitrary = GenT Identity Assertion -> Gen Assertion
forall a. Gen a -> Gen a
TQH.hedgehog GenT Identity Assertion
genAssertion

instance Arbitrary AuthnRequest where
  arbitrary :: Gen AuthnRequest
arbitrary = Gen AuthnRequest -> Gen AuthnRequest
forall a. Gen a -> Gen a
TQH.hedgehog Gen AuthnRequest
genAuthnRequest

instance Arbitrary Conditions where
  arbitrary :: Gen Conditions
arbitrary = GenT Identity Conditions -> Gen Conditions
forall a. Gen a -> Gen a
TQH.hedgehog GenT Identity Conditions
genConditions

instance Arbitrary Config where
  arbitrary :: Gen Config
arbitrary = Gen Config -> Gen Config
forall a. Gen a -> Gen a
TQH.hedgehog Gen Config
genConfig

instance Arbitrary Duration where
  arbitrary :: Gen Duration
arbitrary = Gen Duration -> Gen Duration
forall a. Gen a -> Gen a
TQH.hedgehog Gen Duration
genDuration

instance Arbitrary Issuer where
  arbitrary :: Gen Issuer
arbitrary = GenT Identity Issuer -> Gen Issuer
forall a. Gen a -> Gen a
TQH.hedgehog GenT Identity Issuer
genIssuer

instance Arbitrary Locality where
  arbitrary :: Gen Locality
arbitrary = GenT Identity Locality -> Gen Locality
forall a. Gen a -> Gen a
TQH.hedgehog GenT Identity Locality
genLocality

instance Arbitrary NameID where
  arbitrary :: Gen NameID
arbitrary = Gen NameID -> Gen NameID
forall a. Gen a -> Gen a
TQH.hedgehog Gen NameID
genNameID

instance (Arbitrary payload) => Arbitrary (Response payload) where
  arbitrary :: Gen (Response payload)
arbitrary = Gen (Response payload) -> Gen (Response payload)
forall a. Gen a -> Gen a
TQH.hedgehog (Gen payload -> Gen (Response payload)
forall payload. Gen payload -> Gen (Response payload)
genResponse (Gen payload -> Gen (Response payload))
-> Gen payload -> Gen (Response payload)
forall a b. (a -> b) -> a -> b
$ Gen payload -> Gen payload
forall (m :: * -> *) a. MonadGen m => Gen a -> m a
THQ.quickcheck Gen payload
forall a. Arbitrary a => Gen a
arbitrary)

instance Arbitrary SubjectConfirmationData where
  arbitrary :: Gen SubjectConfirmationData
arbitrary = GenT Identity SubjectConfirmationData
-> Gen SubjectConfirmationData
forall a. Gen a -> Gen a
TQH.hedgehog GenT Identity SubjectConfirmationData
genSubjectConfirmationData

instance Arbitrary SubjectConfirmationMethod where
  arbitrary :: Gen SubjectConfirmationMethod
arbitrary = GenT Identity SubjectConfirmationMethod
-> Gen SubjectConfirmationMethod
forall a. Gen a -> Gen a
TQH.hedgehog GenT Identity SubjectConfirmationMethod
genSubjectConfirmationMethod

instance Arbitrary Time where
  arbitrary :: Gen Time
arbitrary = GenT Identity Time -> Gen Time
forall a. Gen a -> Gen a
TQH.hedgehog GenT Identity Time
genTime

instance Arbitrary UnqualifiedNameID where
  arbitrary :: Gen UnqualifiedNameID
arbitrary = Gen UnqualifiedNameID -> Gen UnqualifiedNameID
forall a. Gen a -> Gen a
TQH.hedgehog Gen UnqualifiedNameID
genUnqualifiedNameID

instance Arbitrary URI where
  arbitrary :: Gen URI
arbitrary = Gen URI -> Gen URI
forall a. Gen a -> Gen a
TQH.hedgehog Gen URI
genHttps

instance Arbitrary IdPId where
  arbitrary :: Gen IdPId
arbitrary = Gen IdPId -> Gen IdPId
forall a. Gen a -> Gen a
TQH.hedgehog Gen IdPId
genIdPId

instance Arbitrary X509.SignedCertificate where
  arbitrary :: Gen SignedCertificate
arbitrary = GenT Identity SignedCertificate -> Gen SignedCertificate
forall a. Gen a -> Gen a
TQH.hedgehog GenT Identity SignedCertificate
genSignedCertificate

instance (Arbitrary a) => Arbitrary (IdPConfig a) where
  arbitrary :: Gen (IdPConfig a)
arbitrary = Gen (IdPConfig a) -> Gen (IdPConfig a)
forall a. Gen a -> Gen a
TQH.hedgehog (Gen a -> Gen (IdPConfig a)
forall a. Gen a -> Gen (IdPConfig a)
genIdPConfig (Gen a -> Gen a
forall (m :: * -> *) a. MonadGen m => Gen a -> m a
THQ.quickcheck Gen a
forall a. Arbitrary a => Gen a
arbitrary))

instance (Arbitrary a) => Arbitrary (FormRedirect a) where
  arbitrary :: Gen (FormRedirect a)
arbitrary = Gen (FormRedirect a) -> Gen (FormRedirect a)
forall a. Gen a -> Gen a
TQH.hedgehog (Gen a -> Gen (FormRedirect a)
forall a. Gen a -> Gen (FormRedirect a)
genFormRedirect (Gen a -> Gen a
forall (m :: * -> *) a. MonadGen m => Gen a -> m a
THQ.quickcheck Gen a
forall a. Arbitrary a => Gen a
arbitrary))

instance Arbitrary Document where
  arbitrary :: Gen Document
arbitrary = Gen Document -> Gen Document
forall a. Gen a -> Gen a
TQH.hedgehog Gen Document
genXMLDocument
  shrink :: Document -> [Document]
shrink (Document Prologue
pro Element
el [Miscellaneous]
epi) = (\Element
el' -> Prologue -> Element -> [Miscellaneous] -> Document
Document Prologue
pro Element
el' [Miscellaneous]
epi) (Element -> Document) -> [Element] -> [Document]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> [Element]
shrinkElement Element
el

instance Arbitrary Node where
  arbitrary :: Gen Node
arbitrary = Gen Node -> Gen Node
forall a. Gen a -> Gen a
TQH.hedgehog Gen Node
genXMLNode
  shrink :: Node -> [Node]
shrink = Node -> [Node]
shrinkNode

instance Arbitrary Name where
  arbitrary :: Gen Name
arbitrary = GenT Identity Name -> Gen Name
forall a. Gen a -> Gen a
TQH.hedgehog GenT Identity Name
genXMLName

instance Arbitrary IdPMetadata where
  arbitrary :: Gen IdPMetadata
arbitrary = Gen IdPMetadata -> Gen IdPMetadata
forall a. Gen a -> Gen a
TQH.hedgehog Gen IdPMetadata
genIdPMetadata

shrinkElement :: Element -> [Element]
shrinkElement :: Element -> [Element]
shrinkElement (Element Name
tag Map Name Text
attrs [Node]
nodes) = case (Map Name Text -> [Map Name Text]
shrinkAttrs Map Name Text
attrs, [Node] -> [[Node]]
forall a. Arbitrary a => a -> [a]
shrink [Node]
nodes) of
  ([], []) -> []
  ([Map Name Text]
attrs', []) -> (\Map Name Text
shrunk -> Name -> Map Name Text -> [Node] -> Element
Element Name
tag Map Name Text
shrunk [Node]
nodes) (Map Name Text -> Element) -> [Map Name Text] -> [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Map Name Text]
attrs'
  ([], [[Node]]
nodes') -> (\[Node]
shrunk -> Name -> Map Name Text -> [Node] -> Element
Element Name
tag Map Name Text
attrs [Node]
shrunk) ([Node] -> Element) -> [[Node]] -> [Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Node]]
nodes'
  ([Map Name Text]
attrs', [[Node]]
nodes') -> Name -> Map Name Text -> [Node] -> Element
Element Name
tag (Map Name Text -> [Node] -> Element)
-> [Map Name Text] -> [[Node] -> Element]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Map Name Text]
attrs' [[Node] -> Element] -> [[Node]] -> [Element]
forall a b. [a -> b] -> [a] -> [b]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [[Node]]
nodes'

shrinkAttrs :: Map.Map Name ST.Text -> [Map.Map Name ST.Text]
shrinkAttrs :: Map Name Text -> [Map Name Text]
shrinkAttrs = ([(Name, Text)] -> Map Name Text)
-> [[(Name, Text)]] -> [Map Name Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Name, Text)] -> Map Name Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([[(Name, Text)]] -> [Map Name Text])
-> (Map Name Text -> [[(Name, Text)]])
-> Map Name Text
-> [Map Name Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Name, Text)] -> [[(Name, Text)]]
forall a. Eq a => [a] -> [[a]]
shallowShrinkList ([(Name, Text)] -> [[(Name, Text)]])
-> (Map Name Text -> [(Name, Text)])
-> Map Name Text
-> [[(Name, Text)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Name Text -> [(Name, Text)]
forall k a. Map k a -> [(k, a)]
Map.toList

shrinkNode :: Node -> [Node]
shrinkNode :: Node -> [Node]
shrinkNode (NodeElement Element
el) = Element -> Node
NodeElement (Element -> Node) -> [Element] -> [Node]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> [Element]
shrinkElement Element
el
shrinkNode (NodeInstruction Instruction
_) = []
shrinkNode (NodeContent Text
"") = []
shrinkNode (NodeContent Text
_) = [Text -> Node
NodeContent Text
""]
shrinkNode (NodeComment Text
"") = []
shrinkNode (NodeComment Text
_) = [Text -> Node
NodeComment Text
""]

shallowShrinkList :: (Eq a) => [a] -> [[a]]
shallowShrinkList :: forall a. Eq a => [a] -> [[a]]
shallowShrinkList [] = []
shallowShrinkList [a
_] = []
shallowShrinkList xs :: [a]
xs@(a
_ : a
_ : [a]
_) = [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: ((a -> [a] -> [a]
forall a. a -> [a] -> [a]
: []) (a -> [a]) -> [a] -> [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
xs)

-- copied from from lens-datetime

diffTOD :: Iso' DiffTime TimeOfDay
diffTOD :: Iso' DiffTime TimeOfDay
diffTOD = (DiffTime -> TimeOfDay)
-> (TimeOfDay -> DiffTime) -> Iso' DiffTime TimeOfDay
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso DiffTime -> TimeOfDay
timeToTimeOfDay TimeOfDay -> DiffTime
timeOfDayToTime

timeAsDiff :: Lens' UTCTime DiffTime
timeAsDiff :: Lens' UTCTime DiffTime
timeAsDiff DiffTime -> f DiffTime
f (UTCTime Day
d DiffTime
t) = Day -> DiffTime -> UTCTime
UTCTime Day
d (DiffTime -> UTCTime) -> f DiffTime -> f UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiffTime -> f DiffTime
f DiffTime
t

-- | Lens into the second value of a 'Timeable'.
--
-- Warning: this is not a proper lens for 'UTCTime': it only obeys the
-- lens laws if used with valid values.
seconds :: Lens' UTCTime Pico
seconds :: Lens' UTCTime Pico
seconds = (DiffTime -> f DiffTime) -> UTCTime -> f UTCTime
Lens' UTCTime DiffTime
timeAsDiff ((DiffTime -> f DiffTime) -> UTCTime -> f UTCTime)
-> ((Pico -> f Pico) -> DiffTime -> f DiffTime)
-> (Pico -> f Pico)
-> UTCTime
-> f UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TimeOfDay -> f TimeOfDay) -> DiffTime -> f DiffTime
Iso' DiffTime TimeOfDay
diffTOD ((TimeOfDay -> f TimeOfDay) -> DiffTime -> f DiffTime)
-> ((Pico -> f Pico) -> TimeOfDay -> f TimeOfDay)
-> (Pico -> f Pico)
-> DiffTime
-> f DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pico -> f Pico) -> TimeOfDay -> f TimeOfDay
forall {f :: * -> *}.
Functor f =>
(Pico -> f Pico) -> TimeOfDay -> f TimeOfDay
seconds'
  where
    seconds' :: (Pico -> f Pico) -> TimeOfDay -> f TimeOfDay
seconds' Pico -> f Pico
f (TimeOfDay Int
h Int
m Pico
s) = Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h Int
m (Pico -> TimeOfDay) -> f Pico -> f TimeOfDay
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pico -> f Pico
f Pico
s