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

module SAML2.WebSSO.Test.Arbitrary where

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

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
  Text
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
  Text
path <- 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
0 Int
5) GenT Identity Text
genNiceWord
  Maybe Int
mMaxLen :: Maybe Int <- GenT Identity (Maybe Int)
-> (Range Int -> GenT Identity (Maybe Int))
-> Maybe (Range Int)
-> GenT Identity (Maybe Int)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Int -> GenT Identity (Maybe Int)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Int
forall a. Maybe a
Nothing) ((Int -> Maybe Int)
-> GenT Identity Int -> GenT Identity (Maybe Int)
forall a b. (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Maybe Int
forall a. a -> Maybe a
Just (GenT Identity Int -> GenT Identity (Maybe Int))
-> (Range Int -> GenT Identity Int)
-> Range Int
-> GenT Identity (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range Int -> GenT Identity Int
forall (m :: * -> *) a. (MonadGen m, Integral a) => Range a -> m a
Gen.integral_) Maybe (Range Int)
glen
  let uri :: Text
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
  (String -> Gen URI)
-> (URI -> Gen URI) -> Either String URI -> Gen URI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Gen URI
forall a. HasCallStack => String -> a
error (String -> Gen URI) -> (String -> String) -> String -> Gen URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. Show a => a -> String
show) URI -> Gen URI
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String URI -> Gen URI) -> Either String URI -> Gen URI
forall a b. (a -> b) -> a -> b
$ Text -> Either String URI
forall (m :: * -> *). MonadError String m => Text -> m URI
parseURI' Text
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)

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

genConfig :: Gen Config
genConfig :: Gen Config
genConfig = do
  Level
_cfgLogLevel <- GenT Identity Level
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded
  String
_cfgSPHost <- Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> GenT Identity Text -> GenT Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord
  Int
_cfgSPPort <- Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
9999)
  URI
_cfgSPAppURI <- Gen URI
genHttps
  URI
_cfgSPSsoURI <- Gen URI
genHttps
  [ContactPerson]
_cfgContacts <- Range Int
-> GenT Identity ContactPerson -> GenT Identity [ContactPerson]
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) GenT Identity ContactPerson
genSPContactPerson
  Config -> Gen Config
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config {Int
String
[ContactPerson]
URI
Level
_cfgLogLevel :: Level
_cfgSPHost :: String
_cfgSPPort :: Int
_cfgSPAppURI :: URI
_cfgSPSsoURI :: URI
_cfgContacts :: [ContactPerson]
_cfgLogLevel :: Level
_cfgSPHost :: String
_cfgSPPort :: Int
_cfgSPAppURI :: URI
_cfgSPSsoURI :: URI
_cfgContacts :: [ContactPerson]
..}

genSPContactPerson :: Gen ContactPerson
genSPContactPerson :: GenT Identity ContactPerson
genSPContactPerson =
  ContactType
-> Maybe XmlText
-> Maybe XmlText
-> Maybe XmlText
-> Maybe URI
-> Maybe XmlText
-> ContactPerson
ContactPerson
    (ContactType
 -> Maybe XmlText
 -> Maybe XmlText
 -> Maybe XmlText
 -> Maybe URI
 -> Maybe XmlText
 -> ContactPerson)
-> GenT Identity ContactType
-> GenT
     Identity
     (Maybe XmlText
      -> Maybe XmlText
      -> Maybe XmlText
      -> Maybe URI
      -> Maybe XmlText
      -> 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 XmlText
   -> Maybe XmlText
   -> Maybe XmlText
   -> Maybe URI
   -> Maybe XmlText
   -> ContactPerson)
-> GenT Identity (Maybe XmlText)
-> GenT
     Identity
     (Maybe XmlText
      -> Maybe XmlText -> Maybe URI -> Maybe XmlText -> 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 XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord)
    GenT
  Identity
  (Maybe XmlText
   -> Maybe XmlText -> Maybe URI -> Maybe XmlText -> ContactPerson)
-> GenT Identity (Maybe XmlText)
-> GenT
     Identity
     (Maybe XmlText -> Maybe URI -> Maybe XmlText -> 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 XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord)
    GenT
  Identity
  (Maybe XmlText -> Maybe URI -> Maybe XmlText -> ContactPerson)
-> GenT Identity (Maybe XmlText)
-> GenT Identity (Maybe URI -> Maybe XmlText -> 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 XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord)
    GenT Identity (Maybe URI -> Maybe XmlText -> ContactPerson)
-> GenT Identity (Maybe URI)
-> GenT Identity (Maybe XmlText -> 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 XmlText -> ContactPerson)
-> GenT Identity (Maybe XmlText) -> 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 XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  ID SPMetadata
_spID <- Gen (ID SPMetadata)
forall {k} (a :: k). Gen (ID a)
genID
  UTCTime
_spValidUntil <- Time -> UTCTime
fromTime (Time -> UTCTime) -> GenT Identity Time -> GenT Identity UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Time
genTime
  NominalDiffTime
_spCacheDuration <- Gen NominalDiffTime
genNominalDifftime
  XmlText
_spOrgName <- Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord
  XmlText
_spOrgDisplayName <- Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord
  URI
_spOrgURL <- Gen URI
genHttps
  URI
_spResponseURL <- Gen URI
genHttps
  [ContactPerson]
_spContacts <- Range Int
-> GenT Identity ContactPerson -> GenT Identity [ContactPerson]
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) GenT Identity ContactPerson
genContactPerson
  SPMetadata -> Gen SPMetadata
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SPMetadata {[ContactPerson]
UTCTime
NominalDiffTime
URI
ID SPMetadata
XmlText
_spID :: ID SPMetadata
_spValidUntil :: UTCTime
_spCacheDuration :: NominalDiffTime
_spOrgName :: XmlText
_spOrgDisplayName :: XmlText
_spOrgURL :: URI
_spResponseURL :: URI
_spContacts :: [ContactPerson]
_spID :: ID SPMetadata
_spValidUntil :: UTCTime
_spCacheDuration :: NominalDiffTime
_spOrgName :: XmlText
_spOrgDisplayName :: XmlText
_spOrgURL :: URI
_spResponseURL :: URI
_spContacts :: [ContactPerson]
..}

genContactPerson :: Gen ContactPerson
genContactPerson :: GenT Identity ContactPerson
genContactPerson = do
  ContactType
_cntType <- GenT Identity ContactType
forall (m :: * -> *) a. (MonadGen m, Enum a, Bounded a) => m a
Gen.enumBounded
  Maybe XmlText
_cntCompany <- GenT Identity XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord)
  Maybe XmlText
_cntGivenName <- GenT Identity XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord)
  Maybe XmlText
_cntSurname <- GenT Identity XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord)
  Maybe URI
_cntEmail <- Gen URI -> GenT Identity (Maybe URI)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe Gen URI
genEmailURI
  Maybe XmlText
_cntPhone <- GenT Identity XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord)
  ContactPerson -> GenT Identity ContactPerson
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContactPerson {Maybe URI
Maybe XmlText
ContactType
_cntType :: ContactType
_cntCompany :: Maybe XmlText
_cntGivenName :: Maybe XmlText
_cntSurname :: Maybe XmlText
_cntEmail :: Maybe URI
_cntPhone :: Maybe XmlText
_cntType :: ContactType
_cntCompany :: Maybe XmlText
_cntGivenName :: Maybe XmlText
_cntSurname :: Maybe XmlText
_cntEmail :: Maybe URI
_cntPhone :: Maybe XmlText
..}

genEmailURI :: Gen URI
genEmailURI :: Gen URI
genEmailURI = do
  Text
loc <- GenT Identity Text
genNiceWord
  URI -> Gen URI
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URI -> Gen URI) -> (Text -> URI) -> Text -> Gen URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> URI
unsafeParseURI (Text -> Gen URI) -> Text -> Gen URI
forall a b. (a -> b) -> a -> b
$ Text
"email:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
loc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@example.com"

genEmail :: HasCallStack => Gen (CI.CI Email.Email)
genEmail :: HasCallStack => Gen (CI Email)
genEmail = do
  Text
loc <- GenT Identity Text
genNiceWord
  (String -> Gen (CI Email))
-> (CI Email -> Gen (CI Email))
-> Either String (CI Email)
-> Gen (CI Email)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Gen (CI Email)
forall a. HasCallStack => String -> a
error (String -> Gen (CI Email))
-> (String -> String) -> String -> Gen (CI Email)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"genEmail: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)) CI Email -> Gen (CI Email)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String (CI Email) -> Gen (CI Email))
-> (Text -> Either String (CI Email)) -> Text -> Gen (CI Email)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either String (CI Email)
forall s.
ConvertibleStrings s ByteString =>
s -> Either String (CI Email)
Email.validate (Text -> Gen (CI Email)) -> Text -> Gen (CI Email)
forall a b. (a -> b) -> a -> b
$ Text
loc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"@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
mkID (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 XmlText -> Bool -> NameIdPolicy
NameIdPolicy
    (NameIDFormat -> Maybe XmlText -> Bool -> NameIdPolicy)
-> GenT Identity NameIDFormat
-> GenT Identity (Maybe XmlText -> Bool -> NameIdPolicy)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity NameIDFormat
genNameIDFormat
    GenT Identity (Maybe XmlText -> Bool -> NameIdPolicy)
-> GenT Identity (Maybe XmlText)
-> 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 XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  UnqualifiedNameID
unid <- Gen UnqualifiedNameID
genUnqualifiedNameID
  case UnqualifiedNameID
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
    [ XmlText -> UnqualifiedNameID
UNameIDUnspecified (XmlText -> UnqualifiedNameID)
-> GenT Identity XmlText -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity XmlText
forall {f :: * -> *}. MonadGen f => Int -> f XmlText
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,
      XmlText -> UnqualifiedNameID
UNameIDX509 (XmlText -> UnqualifiedNameID)
-> GenT Identity XmlText -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity XmlText
forall {f :: * -> *}. MonadGen f => Int -> f XmlText
mktxt Int
2000,
      XmlText -> UnqualifiedNameID
UNameIDWindows (XmlText -> UnqualifiedNameID)
-> GenT Identity XmlText -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity XmlText
forall {f :: * -> *}. MonadGen f => Int -> f XmlText
mktxt Int
2000,
      XmlText -> UnqualifiedNameID
UNameIDKerberos (XmlText -> UnqualifiedNameID)
-> GenT Identity XmlText -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity XmlText
forall {f :: * -> *}. MonadGen f => Int -> f XmlText
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)),
      XmlText -> UnqualifiedNameID
UNameIDPersistent (XmlText -> UnqualifiedNameID)
-> GenT Identity XmlText -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity XmlText
forall {f :: * -> *}. MonadGen f => Int -> f XmlText
mktxt Int
1024,
      XmlText -> UnqualifiedNameID
UNameIDTransient (XmlText -> UnqualifiedNameID)
-> GenT Identity XmlText -> Gen UnqualifiedNameID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> GenT Identity XmlText
forall {f :: * -> *}. MonadGen f => Int -> f XmlText
mktxt Int
2000
    ]
  where
    mktxt :: Int -> f XmlText
mktxt Int
charlen = Text -> XmlText
mkXmlText (Text -> XmlText) -> f Text -> f XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> f Char -> f 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) f 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
  ID (Response payload)
_rspID <- Gen (ID (Response payload))
forall {k} (a :: k). Gen (ID a)
genID
  Maybe (ID AuthnRequest)
_rspInRespTo <- GenT Identity (ID AuthnRequest)
-> GenT Identity (Maybe (ID AuthnRequest))
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity (ID AuthnRequest)
forall {k} (a :: k). Gen (ID a)
genID
  Time
_rspIssueInstant <- GenT Identity Time
genTime
  Maybe URI
_rspDestination <- Gen URI -> GenT Identity (Maybe URI)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe Gen URI
genHttps
  Maybe Issuer
_rspIssuer <- GenT Identity Issuer -> GenT Identity (Maybe Issuer)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Issuer
genIssuer
  Status
_rspStatus <- Gen Status
genStatus
  payload
_rspPayload <- Gen payload -> Gen payload
forall (m :: * -> *) a. MonadGen m => m a -> m a
Gen.small Gen payload
genPayload
  Response payload -> Gen (Response payload)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response {payload
Maybe URI
Maybe (ID AuthnRequest)
Maybe Issuer
Status
ID (Response payload)
Time
_rspID :: ID (Response payload)
_rspInRespTo :: Maybe (ID AuthnRequest)
_rspIssueInstant :: Time
_rspDestination :: Maybe URI
_rspIssuer :: Maybe Issuer
_rspStatus :: Status
_rspPayload :: payload
_rspID :: ID (Response payload)
_rspInRespTo :: Maybe (ID AuthnRequest)
_rspIssueInstant :: Time
_rspDestination :: Maybe URI
_rspIssuer :: Maybe Issuer
_rspStatus :: Status
_rspPayload :: payload
..}

genAssertion :: Gen Assertion
genAssertion :: GenT Identity Assertion
genAssertion = do
  ID Assertion
_assID <- Gen (ID Assertion)
forall {k} (a :: k). Gen (ID a)
genID
  Time
_assIssueInstant <- GenT Identity Time
genTime
  Issuer
_assIssuer <- GenT Identity Issuer
genIssuer
  Maybe Conditions
_assConditions <- GenT Identity Conditions -> GenT Identity (Maybe Conditions)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Conditions
genConditions
  SubjectAndStatements
_assContents <- Gen SubjectAndStatements
genSubjectAndStatements
  Assertion -> GenT Identity Assertion
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Assertion {Maybe Conditions
SubjectAndStatements
ID Assertion
Time
Issuer
_assID :: ID Assertion
_assIssueInstant :: Time
_assIssuer :: Issuer
_assConditions :: Maybe Conditions
_assContents :: SubjectAndStatements
_assID :: ID Assertion
_assIssueInstant :: Time
_assIssuer :: Issuer
_assConditions :: Maybe Conditions
_assContents :: SubjectAndStatements
..}

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
  Maybe Time
_scdNotBefore <- GenT Identity Time -> GenT Identity (Maybe Time)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Time
genTime
  Time
_scdNotOnOrAfter <- GenT Identity Time
genTime
  URI
_scdRecipient <- Gen URI
genHttps
  Maybe (ID AuthnRequest)
_scdInResponseTo <- GenT Identity (ID AuthnRequest)
-> GenT Identity (Maybe (ID AuthnRequest))
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity (ID AuthnRequest)
forall {k} (a :: k). Gen (ID a)
genID
  Maybe IP
_scdAddress <- GenT Identity IP -> GenT Identity (Maybe IP)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity IP
genIP
  SubjectConfirmationData -> GenT Identity SubjectConfirmationData
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SubjectConfirmationData {Maybe IP
Maybe (ID AuthnRequest)
Maybe Time
URI
Time
_scdNotBefore :: Maybe Time
_scdNotOnOrAfter :: Time
_scdRecipient :: URI
_scdInResponseTo :: Maybe (ID AuthnRequest)
_scdAddress :: Maybe IP
_scdNotBefore :: Maybe Time
_scdNotOnOrAfter :: Time
_scdRecipient :: URI
_scdInResponseTo :: Maybe (ID AuthnRequest)
_scdAddress :: Maybe IP
..}

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
  Time
_astAuthnInstant <- GenT Identity Time
genTime
  Maybe XmlText
_astSessionIndex <- GenT Identity XmlText -> GenT Identity (Maybe XmlText)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> XmlText
mkXmlText (Text -> XmlText) -> GenT Identity Text -> GenT Identity XmlText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity Text
genNiceWord)
  Maybe Time
_astSessionNotOnOrAfter <- GenT Identity Time -> GenT Identity (Maybe Time)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Time
genTime
  Maybe Locality
_astSubjectLocality <- GenT Identity Locality -> GenT Identity (Maybe Locality)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe GenT Identity Locality
genLocality
  Statement -> Gen Statement
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthnStatement {Maybe Locality
Maybe Time
Maybe XmlText
Time
_astAuthnInstant :: Time
_astSessionIndex :: Maybe XmlText
_astSessionNotOnOrAfter :: Maybe Time
_astSubjectLocality :: Maybe Locality
_astAuthnInstant :: Time
_astSessionIndex :: Maybe XmlText
_astSessionNotOnOrAfter :: Maybe Time
_astSubjectLocality :: Maybe Locality
..}

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
  Element
el <- Gen Element
genXMLElement
  Document -> Gen Document
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Document -> Gen Document) -> Document -> Gen Document
forall a b. (a -> b) -> a -> b
$ Prologue -> Element -> [Miscellaneous] -> Document
Document ([Miscellaneous] -> Maybe Doctype -> [Miscellaneous] -> Prologue
Prologue [] Maybe Doctype
forall a. Maybe a
Nothing []) Element
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
_idpId <- Gen IdPId
genIdPId
  URI
_idpMetadataURI <- Gen URI
genHttps
  IdPMetadata
_idpMetadata <- Gen IdPMetadata
genIdPMetadata
  a
_idpExtraInfo <- Gen a
genExtra
  IdPConfig a -> Gen (IdPConfig a)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IdPConfig {a
IdPId
IdPMetadata
_idpId :: IdPId
_idpMetadata :: IdPMetadata
_idpExtraInfo :: a
_idpId :: IdPId
_idpMetadata :: IdPMetadata
_idpExtraInfo :: a
..}

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
  ByteString
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
  Maybe ByteString
path <-
    [GenT Identity (Maybe ByteString)]
-> GenT Identity (Maybe ByteString)
forall (m :: * -> *) a. MonadGen m => [m a] -> m a
Gen.choice
      [ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> ([Text] -> ByteString) -> [Text] -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> ([Text] -> Text) -> [Text] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
ST.intercalate Text
"/" ([Text] -> Maybe ByteString)
-> GenT Identity [Text] -> GenT Identity (Maybe ByteString)
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
0 Int
3) GenT Identity Text
genNiceWord,
        Maybe ByteString -> GenT Identity (Maybe ByteString)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString -> GenT Identity (Maybe ByteString))
-> Maybe ByteString -> GenT Identity (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"/",
        Maybe ByteString -> GenT Identity (Maybe ByteString)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ByteString
forall a. Maybe a
Nothing
      ]
  Maybe UTCTime
expires <- GenT Identity UTCTime -> GenT Identity (Maybe UTCTime)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (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 GenT Identity UTCTime
-> (UTCTime -> UTCTime) -> GenT Identity UTCTime
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (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
10e12) (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
10e12)) -- only full seconds
  Maybe DiffTime
maxage <- GenT Identity DiffTime -> GenT Identity (Maybe DiffTime)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (GenT Identity DiffTime -> GenT Identity (Maybe DiffTime))
-> GenT Identity DiffTime -> GenT Identity (Maybe DiffTime)
forall a b. (a -> b) -> a -> b
$ Int -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> DiffTime) -> GenT Identity Int -> GenT Identity DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
1000) -- only non-negative, full seconds
  Maybe ByteString
domain <- GenT Identity ByteString -> GenT Identity (Maybe ByteString)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> ByteString) -> ([Text] -> Text) -> [Text] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
ST.intercalate Text
"." ([Text] -> ByteString)
-> GenT Identity [Text] -> GenT Identity ByteString
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
3) GenT Identity Text
genNiceWord)
  Bool
httponly <- GenT Identity Bool
forall (m :: * -> *). MonadGen m => m Bool
Gen.bool
  Bool
secure <- GenT Identity Bool
forall (m :: * -> *). MonadGen m => m Bool
Gen.bool
  Maybe SameSiteOption
samesite <- GenT Identity SameSiteOption
-> GenT Identity (Maybe SameSiteOption)
forall (m :: * -> *) a. MonadGen m => m a -> m (Maybe a)
Gen.maybe (GenT Identity SameSiteOption
 -> GenT Identity (Maybe SameSiteOption))
-> GenT Identity SameSiteOption
-> GenT Identity (Maybe SameSiteOption)
forall a b. (a -> b) -> a -> b
$ [SameSiteOption] -> GenT Identity SameSiteOption
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadGen m) =>
f a -> m a
Gen.element [SameSiteOption
sameSiteLax, SameSiteOption
sameSiteStrict]
  SimpleSetCookie name -> Gen (SimpleSetCookie name)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SimpleSetCookie name -> Gen (SimpleSetCookie name))
-> (SetCookie -> SimpleSetCookie name)
-> SetCookie
-> Gen (SimpleSetCookie name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SetCookie -> SimpleSetCookie name
forall {k} (name :: k). SetCookie -> SimpleSetCookie name
SimpleSetCookie (SetCookie -> Gen (SimpleSetCookie name))
-> SetCookie -> Gen (SimpleSetCookie name)
forall a b. (a -> b) -> a -> b
$
    SetCookie
forall a. Default a => a
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
  Text
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
  MultipartData Mem -> Gen (MultipartData Mem)
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultipartData {files :: [FileData Mem]
files = [], inputs :: [Input]
inputs = [Input {iName :: Text
iName = Text
"SAMLResponse", iValue :: Text
iValue = Text
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