{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-orphans -Wno-duplicate-exports #-}

-- | 'GenValid' instances for 'URI' and 'URIAuth'
--
-- The main API of this module is in the orphan instances @GenValid URI@ and @GenValid URIAuth@.
module Data.GenValidity.URI
  ( -- ** Specific Generators
    genURIReference,
    genURI,
    genRelativeReference,
    genAbsoluteURI,

    -- * Export everything for testing, **You probably do not want to use any of the functions below**.
    module Data.GenValidity.URI,
  )
where

import Data.Char as Char
import Data.GenValidity
import Data.IP
import Data.Validity.URI
import Data.Word
import Network.URI
import Test.QuickCheck
import Text.Printf

-- | Generate an 'URI' that parses using 'parseURIReference'.
genURIReference :: Gen URI
genURIReference =
  oneof
    [ genURI,
      genRelativeReference
    ]

-- | Generate an 'URI' that parses using 'parseURI'.
genURI :: Gen URI
genURI = (`suchThatMap` (parseURI . dangerousURIToString)) $ do
  uriScheme <- genScheme `suchThat` (not . null)
  uriAuthority <- genValid
  uriPath <- case uriAuthority of
    Just _ -> genPathAbEmpty
    Nothing ->
      oneof
        [ genPathAbsolute,
          genPathNoScheme,
          genPathEmpty
        ]
  uriQuery <- genQuery
  uriFragment <- genFragment
  pure URI {..}

-- | Generate an 'URI' that parses using 'parseRelativeReference'.
genRelativeReference :: Gen URI
genRelativeReference = (`suchThatMap` (parseRelativeReference . dangerousURIToString)) $ do
  let uriScheme = ""
  uriAuthority <- genValid
  uriPath <- case uriAuthority of
    Just _ -> genPathAbEmpty
    Nothing ->
      oneof
        [ genPathAbsolute,
          genPathNoScheme,
          genPathEmpty
        ]
  uriQuery <- genQuery
  uriFragment <- genFragment
  pure URI {..}

-- | Generate an 'URI' that parses using 'parseAbsoluteURI'.
genAbsoluteURI :: Gen URI
genAbsoluteURI = (`suchThatMap` (parseAbsoluteURI . dangerousURIToString)) $ do
  uriScheme <- genScheme `suchThat` (not . null)
  uriAuthority <- genValid
  uriPath <- case uriAuthority of
    Just _ -> genPathAbEmpty
    Nothing ->
      oneof
        [ genPathAbsolute,
          genPathNoScheme,
          genPathEmpty
        ]
  uriQuery <- genQuery
  let uriFragment = ""
  pure URI {..}

instance GenValid URIAuth where
  genValid = (`suchThat` isValid) $ do
    uriUserInfo <- genUserInfo
    uriRegName <- genHost
    uriPort <- genPort
    pure $ URIAuth {..}

instance GenValid URI where
  genValid = (`suchThat` isValid) . (`suchThatMap` (parseURIReference . dangerousURIToString)) $ do
    uriScheme <- genScheme
    uriAuthority <- genValid
    uriPath <- genPath
    uriQuery <- genQuery
    uriFragment <- genFragment
    pure $ URI {..}

genScheme :: Gen String
genScheme =
  oneof
    [ pure "",
      nullOrAppend ':'
        <$> ( (:)
                <$> genCharALPHA
                <*> genStringBy
                  ( frequency
                      [ (4, genCharALPHA),
                        (3, genCharDIGIT),
                        (1, elements ['+', '-', '.'])
                      ]
                  )
            ),
      -- Common schemes
      elements
        [ "http:",
          "https:",
          "ftp:",
          "ftps:",
          "ldap:",
          "mailto:",
          "news:",
          "tel:",
          "telnet:",
          "urn:",
          "ws:",
          "wss:"
        ]
    ]

genUserInfo :: Gen String
genUserInfo =
  nullOrAppend '@' . concat
    <$> genListOf
      ( frequency
          [ (4, (: []) <$> genCharUnreserved),
            (1, genPercentEncodedChar),
            (1, (: []) <$> genCharSubDelim),
            (1, pure ":")
          ]
      )

genHost :: Gen String
genHost =
  oneof
    [ genIPLiteral,
      genIPv4Address,
      genRegName
    ]

genIPLiteral :: Gen String
genIPLiteral = do
  a <-
    oneof
      [ genIPv6Address,
        genIPvFuture
      ]
  pure $ "[" ++ a ++ "]"

genIPv6Address :: Gen String
genIPv6Address = show . toIPv6w <$> genValid

genIPvFuture :: Gen String
genIPvFuture = do
  hd <- genStringBy1 genCharHEXDIG
  s <-
    genStringBy1
      ( frequency
          [ (4, genCharUnreserved),
            (1, genCharSubDelim),
            (1, pure ':')
          ]
      )
  pure $ concat ["v", hd, ".", s]

genIPv4Address :: Gen String
genIPv4Address = show . toIPv4w <$> genValid

genRegName :: Gen String
genRegName =
  concat
    <$> genListOf
      ( frequency
          [ (4, (: []) <$> genCharUnreserved),
            (1, genPercentEncodedChar),
            (1, (: []) <$> genCharSubDelim)
          ]
      )

genPort :: Gen String
genPort = nullOrPrepend ':' <$> genStringBy genCharDIGIT

genPercentEncodedChar :: Gen String
genPercentEncodedChar = do
  octet <- choose (0, 255)
  pure $ '%' : printf "%x" (octet :: Word8)

genPath :: Gen String
genPath =
  -- @
  -- path          = path-abempty    ; begins with "/" or is empty
  --               / path-absolute   ; begins with "/" but not "//"
  --               / path-noscheme   ; begins with a non-colon segment
  --               / path-rootless   ; begins with a segment
  --               / path-empty      ; zero characters
  -- @
  oneof
    [ genPathAbEmpty,
      genPathAbsolute,
      genPathNoScheme,
      genPathRootless,
      genPathEmpty
    ]

-- @
-- path-abempty  = *( "/" segment )
-- @
genPathAbEmpty :: Gen String
genPathAbEmpty = do
  segments <- genListOf genSegment
  pure $ concatMap ('/' :) segments

-- @
-- path-absolute = "/" [ segment-nz *( "/" segment ) ]
-- @
genPathAbsolute :: Gen String
genPathAbsolute = do
  firstSegment <- genSegmentNz
  restSegments <- genListOf genSegment
  pure $ '/' : firstSegment ++ concatMap ('/' :) restSegments

-- @
-- path-noscheme = segment-nz-nc *( "/" segment )
-- @
genPathNoScheme :: Gen String
genPathNoScheme = do
  firstSegment <- genSegmentNzNc
  restSegments <- genListOf genSegment
  pure $ firstSegment ++ concatMap ('/' :) restSegments

-- @
-- path-rootless = segment-nz *( "/" segment )
-- @
genPathRootless :: Gen String
genPathRootless = do
  firstSegment <- genSegmentNz
  restSegments <- genListOf genSegment
  pure $ firstSegment ++ concatMap ('/' :) restSegments

-- @
-- path-empty    = 0<pchar>
-- @
genPathEmpty :: Gen String
genPathEmpty = pure ""

-- @
-- segment       = *pchar
-- @
genSegment :: Gen String
genSegment = concat <$> genListOf genPathChar

-- @
-- segment-nz    = 1*pchar
-- @
genSegmentNz :: Gen String
genSegmentNz = concat <$> genListOf1 genPathChar

-- @
-- segment-nz-nc = 1*( unreserved / pct-encoded / sub-delims / "@" )
--               ; non-zero-length segment without any colon ":"
-- @
genSegmentNzNc :: Gen String
genSegmentNzNc =
  concat
    <$> genListOf1
      ( frequency
          [ (4, (: []) <$> genCharUnreserved),
            (1, genPercentEncodedChar),
            (1, (: []) <$> genCharSubDelim),
            (1, pure "@")
          ]
      )

-- @
-- pchar         = unreserved / pct-encoded / sub-delims / ":" / "@"
-- @
genPathChar :: Gen String
genPathChar =
  frequency
    [ (4, (: []) <$> genCharUnreserved),
      (1, genPercentEncodedChar),
      (1, (: []) <$> genCharSubDelim),
      (1, elements [":", "@"])
    ]

-- @
-- query       = *( pchar / "/" / "?" )
-- @
genQuery :: Gen String
genQuery =
  nullOrPrepend '?' . concat
    <$> genListOf
      ( frequency
          [ (4, genPathChar),
            ( 1,
              elements
                [ "/",
                  "?",
                  "&" -- '&' is not specified but very common in queries so we add it here.
                ]
            )
          ]
      )

-- @
-- fragment    = *( pchar / "/" / "?" )
-- @
genFragment :: Gen String
genFragment =
  nullOrPrepend '#' . concat
    <$> genListOf
      ( frequency
          [ (4, genPathChar),
            (1, elements ["/", "?"])
          ]
      )

genCharUnreserved :: Gen Char
genCharUnreserved =
  frequency
    [ (1, elements ['+', '-', '.', '~']),
      (4, genCharALPHA),
      (3, genCharDIGIT)
    ]

genCharReserved :: Gen Char
genCharReserved =
  oneof
    [ genCharGenDelim,
      genCharSubDelim
    ]

genCharGenDelim :: Gen Char
genCharGenDelim =
  elements
    [ ':',
      '/',
      '?',
      '#',
      '[',
      ']',
      '@'
    ]

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

genCharHEXDIG :: Gen Char
genCharHEXDIG = elements $ ['1' .. '9'] ++ ['A' .. 'F'] ++ ['a' .. 'f']

genCharALPHA :: Gen Char
genCharALPHA =
  Char.chr
    <$> oneof
      [ choose (0x41, 0x5A),
        choose (0x61, 0x7A)
      ]

genCharDIGIT :: Gen Char
genCharDIGIT =
  Char.chr
    <$> choose (0x30, 0x39)

nullOrAppend :: Char -> String -> String
nullOrAppend c s = if null s then s else s ++ [c]

nullOrPrepend :: Char -> String -> String
nullOrPrepend c s = if null s then s else c : s