Arbitrary.hs

{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# HLINT ignore "Evaluate" #-}

-- |
-- Module      : Network.URI.Arbitrary
-- Description : Arbitrary Instances for Network.URI
-- Copyright   : (c) Alex Brandt, 2018
-- License     : MIT
--
-- Arbitrary instances for "Network.URI".
module Network.URI.Arbitrary () where

import Control.Monad
  ( replicateM,
  )
import Data.List
  ( intercalate,
  )
import Network.URI
  ( URI (..),
    URIAuth (..),
    parseURIReference,
    uriToString,
  )
import Test.QuickCheck
  ( Arbitrary (arbitrary, shrink),
    Gen,
    choose,
    elements,
    listOf,
    listOf1,
    oneof,
    suchThat,
  )

instance Arbitrary URI where
  arbitrary = do
    uriScheme <- oneof [return "", scheme]
    uriAuthority <- arbitrary :: Gen (Maybe URIAuth)
    uriPath <- path (null uriScheme) $ maybe True emptyAuthority uriAuthority
    uriQuery <- oneof [query, return ""]
    uriFragment <- oneof [fragment, return ""]

    return URI {..}
    where
      emptyAuthority URIAuth {..} = all null [uriUserInfo, uriRegName, uriPort]

  shrink URI {..} =
    filter
      isURI
      [ URI uriScheme' uriAuthority' uriPath' uriQuery' uriFragment'
        | (uriScheme', uriAuthority', uriPath', uriQuery', uriFragment') <-
            shrink
              (uriScheme, uriAuthority, uriPath, uriQuery, uriFragment)
      ]
    where
      isURI u = case parseURIReference (uriToString id u "") of
        Just u' -> u' == u
        Nothing -> False

instance Arbitrary URIAuth where
  arbitrary = URIAuth <$> userinfo <*> host `suchThat` (not . null) <*> port

  shrink URIAuth {..} =
    [ URIAuth uriUserInfo' uriRegName' uriPort'
      | (uriUserInfo', uriRegName', uriPort') <-
          shrink
            (uriUserInfo, uriRegName, uriPort)
    ]

-- * RFC 3986 Generators

--
--   Some generators are handled by the 'Arbitrary' instances above, and
--   others are folded into symbols that are preceded or followed by
--   identifying tokens.

scheme :: Gen String
scheme = do
  a <- alpha
  r <- listOf $ oneof [alpha, digit, elements ['+', '-', '.']]
  return $ a : (r ++ ":")

userinfo :: Gen String
userinfo = do
  u <- concat <$> userinfo'
  if null u then return "" else return $ u ++ "@"
  where
    userinfo' =
      listOf $
        oneof
          [replicateM 1 $ oneof [unreserved, subDelims, return ':'], percentEncoded]

host :: Gen String
host = oneof [ipLiteral, ipv4Address, regName]

port :: Gen String
port = do
  p <- listOf digit
  if null p then return "" else return $ ':' : p

ipLiteral :: Gen String
ipLiteral = do
  x <-
    oneof
      [ ipv6Address
      -- , ipvFuture
      ]
  return $ "[" ++ x ++ "]"

{- TODO Check that "Network.URI" implements this correctly.
ipvFuture :: Gen String
ipvFuture =
  do h <- hexdig
     o <- oneof [ unreserved, subDelims, return ':' ]
     return ['v', h, '.', o]
-}

ipv6Address :: Gen String
ipv6Address =
  concat
    <$> oneof
      [ sequence [b 6, ls32],
        sequence [return "::", b 5, ls32],
        sequence [h16, return "::", b 4, ls32],
        sequence [b 1, h16, return "::", b 3, ls32],
        sequence [b 2, h16, return "::", b 2, ls32],
        sequence [b 3, h16, return "::", b 1, ls32],
        sequence [b 4, h16, return "::", ls32],
        sequence [b 5, h16, return "::", h16],
        sequence [b 6, h16, return "::"]
      ]
  where
    b n = fmap concat $ replicateM n $ fmap (++ ":") h16 :: Gen String

h16 :: Gen String
h16 = replicateM 4 hexdig

ls32 :: Gen String
ls32 = oneof [intercalate ":" <$> replicateM 2 h16, ipv4Address]

ipv4Address :: Gen String
ipv4Address = intercalate "." <$> replicateM 4 decOctet

decOctet :: Gen String
decOctet = (show :: Int -> String) <$> choose (0, 255)

regName :: Gen String
regName =
  fmap concat $
    listOf $
      oneof
        [replicateM 1 unreserved, percentEncoded, replicateM 1 subDelims]

path :: Bool -> Bool -> Gen String
path emptyScheme emptyURIAuth =
  if emptyURIAuth
    then
      oneof
        [ pathAbsolute,
          if emptyScheme then pathNoScheme else pathRootless,
          return ""
        ]
    else pathAbEmpty

pathAbEmpty :: Gen String
pathAbEmpty = concat <$> listOf (('/' :) . concat <$> listOf pchar)

pathAbsolute :: Gen String
pathAbsolute = ('/' :) <$> oneof [return "", pathRootless]

pathNoScheme :: Gen String
pathNoScheme = concat <$> sequence [segment1nc, pathAbEmpty]

pathRootless :: Gen String
pathRootless = concat <$> sequence [concat <$> listOf1 pchar, pathAbEmpty]

segment1nc :: Gen String
segment1nc =
  oneof
    [ replicateM 1 unreserved,
      percentEncoded,
      replicateM 1 subDelims,
      replicateM 1 $ return '@'
    ]

pchar :: Gen String
pchar =
  oneof
    [ replicateM 1 unreserved,
      percentEncoded,
      replicateM 1 subDelims,
      replicateM 1 $ return ':',
      replicateM 1 $ return '@'
    ]

query :: Gen String
query =
  fmap (('?' :) . concat) $ listOf $ oneof [pchar, return "/", return "?"]

fragment :: Gen String
fragment =
  fmap (('#' :) . concat) $ listOf $ oneof [pchar, return "/", return "?"]

percentEncoded :: Gen String
percentEncoded = ('%' :) <$> replicateM 2 hexdig

unreserved :: Gen Char
unreserved = oneof [alpha, digit, elements ['-', '.', '_', '~']]

subDelims :: Gen Char
subDelims = elements ['!', '$', '&', '\'', '(', ')', '*', '+', ',', ';', '=']

-- * RFC 2234 Generators

alpha :: Gen Char
alpha = elements $ ['a' .. 'z'] ++ ['A' .. 'Z']

digit :: Gen Char
digit = elements ['0' .. '9']

hexdig :: Gen Char
hexdig = oneof [digit, elements ['A' .. 'F']]