{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module URI.ByteStringTests (tests) where

-------------------------------------------------------------------------------
import qualified Blaze.ByteString.Builder as BB
import Control.Applicative (Const (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import Data.Either
import Data.Function.Compat ((&))
import Data.Functor.Identity (Identity (..))
import qualified Data.Map.Strict as M
import Data.Monoid
import Hedgehog
import qualified Hedgehog.Gen as Gen
import Safe (readMay)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.Hedgehog
-------------------------------------------------------------------------------

-------------------------------------------------------------------------------
import URI.ByteString
import URI.ByteString.Generators
-------------------------------------------------------------------------------
import URI.ByteStringQQTests ()
import Prelude

infixr 4 .~

(.~) :: ((a -> Identity b) -> s -> Identity t) -> b -> s -> t
(.~) l b s = runIdentity (l (const (Identity b)) s)

infixl 9 ^.

(^.) :: s -> ((a -> Const a a) -> s -> Const a s) -> a
s ^. l = getConst (l Const s)

tests :: TestTree
tests =
  testGroup
    "URI.Bytestring"
    [ parseUriTests,
      uriParseErrorInstancesTests,
      lensTests,
      serializeURITests,
      normalizeURITests
    ]

-------------------------------------------------------------------------------
parseUriTests :: TestTree
parseUriTests =
  testGroup
    "parseUri"
    [ testParses "http://www.example.org/" $
        URI
          (Scheme "http")
          (Just (Authority Nothing (Host "www.example.org") Nothing))
          "/"
          mempty
          Nothing,
      testParseHost "http://www.example.org" "www.example.org",
      -- IPV4
      testParseHost "http://192.168.1.1" "192.168.1.1",
      -- IPV6
      testParseHost "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]" "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210",
      testParseHost "http://[1080:0:0:0:8:800:200C:417A]" "1080:0:0:0:8:800:200C:417A",
      testParseHost "http://[3ffe:2a00:100:7031::1]" "3ffe:2a00:100:7031::1",
      testParseHost "http://[::192.9.5.5]" "::192.9.5.5",
      testParseHost "http://[::FFFF:129.144.52.38]" "::FFFF:129.144.52.38",
      testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179",
      testParseHost "http://[2010:836B:4179::836B:4179]" "2010:836B:4179::836B:4179",
      -- IPVFuture
      testParseHost "http://[v1.fe80::a+en1]" "v1.fe80::a+en1",
      testParses "https://user:pass:wo%20rd@www.example.org?foo=bar&foo=baz+quux#frag" $
        URI
          (Scheme "https")
          (Just (Authority (Just (UserInfo "user" "pass:wo rd")) (Host "www.example.org") Nothing))
          ""
          (Query [("foo", "bar"), ("foo", "baz+quux")])
          (Just "frag"),
      testParses "https://user@www.example.org" $
        URI
          (Scheme "https")
          (Just (Authority (Just (UserInfo "user" "")) (Host "www.example.org") Nothing))
          ""
          (Query [])
          Nothing,
      testParses "https://@www.example.org" $
        URI
          (Scheme "https")
          (Just (Authority (Just (UserInfo "" "")) (Host "www.example.org") Nothing))
          ""
          (Query [])
          Nothing,
      testParses "https://::@www.example.org" $
        URI
          (Scheme "https")
          (Just (Authority (Just (UserInfo "" ":")) (Host "www.example.org") Nothing))
          ""
          (Query [])
          Nothing,
      -- trailing &
      testParses "http://www.example.org?foo=bar&" $
        URI
          (Scheme "http")
          (Just (Authority Nothing (Host "www.example.org") Nothing))
          ""
          (Query [("foo", "bar")])
          Nothing,
      testParses
        "http://www.google.com:80/aclk?sa=l&ai=CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw&sig=AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ&rct=j&q=&ved=0CCUQ0Qw&adurl=http://www.aruba.com/where-to-stay/hotels-and-resorts%3Ftid%3D122"
        URI
          { uriScheme = Scheme {schemeBS = "http"},
            uriAuthority = Just Authority {authorityUserInfo = Nothing, authorityHost = Host {hostBS = "www.google.com"}, authorityPort = Just (Port 80)},
            uriPath = "/aclk",
            uriQuery =
              Query
                { queryPairs =
                    [ ("sa", "l"),
                      ("ai", "CChPOVvnoU8fMDI_QsQeE4oGwDf664-EF7sq01HqV1MMFCAAQAigDUO3VhpcDYMnGqYvApNgPoAGq3vbiA8gBAaoEKE_QQwekDUoMeW9IQghV4HRuzL_l-7vVjlML559kix6XOcC1c4Tb9xeAB76hiR2QBwGoB6a-Gw"),
                      ("sig", "AOD64_3Ulyu0DcDsc1AamOIxq63RF9u4zQ"),
                      ("rct", "j"),
                      ("q", ""),
                      ("ved", "0CCUQ0Qw"),
                      ("adurl", "http://www.aruba.com/where-to-stay/hotels-and-resorts?tid=122")
                    ]
                },
            uriFragment = Nothing
          },
      testParseFailure "$$$$://www.example.org/" (MalformedScheme NonAlphaLeading),
      testParses "http://www.example.org/foo#bar" $
        URI
          (Scheme "http")
          (Just (Authority Nothing (Host "www.example.org") Nothing))
          "/foo"
          mempty
          (Just "bar"),
      testParses "http://www.example.org/foo#" $
        URI
          (Scheme "http")
          (Just (Authority Nothing (Host "www.example.org") Nothing))
          "/foo"
          mempty
          (Just ""),
      testParseFailure "http://www.example.org/foo#bar#baz" MalformedFragment,
      testParseFailure "https://www.example.org?listParam[]=foo,bar" MalformedQuery,
      testParsesLax "https://www.example.org?listParam[]=foo,bar" $
        URI
          (Scheme "https")
          (Just (Authority Nothing (Host "www.example.org") Nothing))
          ""
          (Query [("listParam[]", "foo,bar")])
          Nothing,
      testParses "https://www.example.org?listParam%5B%5D=foo,bar" $
        URI
          (Scheme "https")
          (Just (Authority Nothing (Host "www.example.org") Nothing))
          ""
          (Query [("listParam[]", "foo,bar")])
          Nothing,
      testParses "https://www.example.org#only-fragment" $
        URI
          (Scheme "https")
          (Just (Authority Nothing (Host "www.example.org") Nothing))
          ""
          (Query [])
          (Just "only-fragment"),
      testParses "https://www.example.org/weird%20path" $
        URI
          (Scheme "https")
          (Just (Authority Nothing (Host "www.example.org") Nothing))
          "/weird path"
          (Query [])
          Nothing,
      parseTestURI strictURIParserOptions "http://www.example.org/." $
        Right $
          URI
            (Scheme "http")
            (Just (Authority Nothing (Host "www.example.org") Nothing))
            "/."
            (Query [])
            Nothing,
      parseTestURI strictURIParserOptions "http:/." $
        Right $
          URI
            (Scheme "http")
            Nothing
            "/."
            (Query [])
            Nothing,
      parseTestURI strictURIParserOptions "file:c:/foo" $
        Right $
          URI
            (Scheme "file")
            Nothing
            "c:/foo"
            (Query [])
            Nothing,
      parseTestURI strictURIParserOptions "file:///foo/%F" $
        Left MalformedPath,
      parseTestURI strictURIParserOptions "file:///foo/?foo=%F" $
        Left MalformedQuery,
      roundtripTestURI strictURIParserOptions "ftp://ftp.is.co.za/rfc/rfc1808.txt",
      roundtripTestURI strictURIParserOptions "http://www.ietf.org/rfc/rfc2396.txt",
      roundtripTestURI strictURIParserOptions "mailto:John.Doe@example.com",
      roundtripTestURI strictURIParserOptions "news:comp.infosystems.www.servers.unix",
      roundtripTestURI strictURIParserOptions "tel:+1-816-555-1212",
      roundtripTestURI strictURIParserOptions "telnet://192.0.2.16:80/",
      -- percent encoding in queries and fragments
      roundtripTestURI strictURIParserOptions "http://example.com/foo#bar%20baz",
      roundtripTestURI strictURIParserOptions "http://example.com/foo?bar%20baz=quux",
      roundtripTestURI strictURIParserOptions "http://example.com/foo?bar=baz%20quux",
      roundtripTestURI strictURIParserOptions "http://example.com/foo?bar=baz%20quux#bar%20baz",
      -- RFC 3986, Section 4.2
      parseTestRelativeRef strictURIParserOptions "verysimple" $
        Right $
          RelativeRef
            Nothing
            "verysimple"
            (Query [])
            Nothing,
      parseTestRelativeRef strictURIParserOptions "this:that/thap/sub?1=2" $
        Left $
          MalformedPath,
      parseTestRelativeRef strictURIParserOptions "./this:that/thap/sub?1=2" $
        Right $
          RelativeRef
            Nothing
            "./this:that/thap/sub"
            (Query [("1", "2")])
            Nothing
    ]

-------------------------------------------------------------------------------
uriParseErrorInstancesTests :: TestTree
uriParseErrorInstancesTests =
  testGroup
    "URIParseError instances"
    [ testProperty "roundtrips between Show and Read" $
        property $ do
          parseError <- forAll genURIParseError
          trippingShow parseError
    ]

-------------------------------------------------------------------------------
lensTests :: TestTree
lensTests =
  testGroup
    "lenses"
    [ testProperty "schemeBSL Lens" $
        property $ do
          wrapped <- forAll genScheme
          Scheme bs' <- forAll genScheme
          (wrapped ^. schemeBSL) === schemeBS wrapped
          (wrapped & schemeBSL .~ bs') === wrapped {schemeBS = bs'},
      testProperty "hostBSL Lens" $
        property $ do
          wrapped <- forAll genHost
          Host bs' <- forAll genHost
          (wrapped ^. hostBSL) === hostBS wrapped
          (wrapped & hostBSL .~ bs') === wrapped {hostBS = bs'},
      testProperty "portNumberL Lens" $
        property $ do
          wrapped <- forAll genPort
          Port n' <- forAll genPort
          (wrapped ^. portNumberL) === portNumber wrapped
          (wrapped & portNumberL .~ n') === wrapped {portNumber = n'},
      testProperty "queryPairsL Lens" $
        property $ do
          wrapped <- forAll genQuery
          Query ps' <- forAll genQuery
          wrapped ^. queryPairsL === queryPairs wrapped
          (wrapped & queryPairsL .~ ps') === wrapped {queryPairs = ps'},
      testProperty "authorityUserInfoL Lens" $
        property $ do
          authority <- forAll genAuthority
          userInfo <- forAll (Gen.maybe genUserInfo)
          (authority ^. authorityUserInfoL === authorityUserInfo authority)
          (authority & authorityUserInfoL .~ userInfo) === authority {authorityUserInfo = userInfo},
      testProperty "authorityHostL Lens" $
        property $ do
          authority <- forAll genAuthority
          host <- forAll genHost
          (authority ^. authorityHostL === authorityHost authority)
          (authority & authorityHostL .~ host) === authority {authorityHost = host},
      testProperty "authorityPortL Lens" $
        property $ do
          authority <- forAll genAuthority
          port <- forAll (Gen.maybe genPort)
          (authority ^. authorityPortL === authorityPort authority)
          (authority & authorityPortL .~ port) === authority {authorityPort = port},
      testProperty "uiUsernameL Lens" $
        property $ do
          ui <- forAll genUserInfo
          bs <- forAll genBS
          (ui ^. uiUsernameL === uiUsername ui)
          (ui & uiUsernameL .~ bs) === ui {uiUsername = bs},
      testProperty "uiPasswordL Lens" $
        property $ do
          ui <- forAll genUserInfo
          bs <- forAll genBS
          (ui ^. uiPasswordL === uiPassword ui)
          (ui & uiPasswordL .~ bs) === ui {uiPassword = bs},
      testProperty "uriSchemeL Lens" $
        property $ do
          uri <- forAll genAbsoluteURIRef
          x <- forAll genScheme
          uri ^. uriSchemeL === uriScheme uri
          (uri & uriSchemeL .~ x) === uri {uriScheme = x},
      testProperty "authorityL Lens on URI" $
        property $ do
          uri <- forAll genAbsoluteURIRef
          x <- forAll (Gen.maybe genAuthority)
          uri ^. authorityL === uriAuthority uri
          (uri & authorityL .~ x) === uri {uriAuthority = x},
      testProperty "pathL Lens on URI" $
        property $ do
          uri <- forAll genAbsoluteURIRef
          x <- forAll genBS
          uri ^. pathL === uriPath uri
          (uri & pathL .~ x) === uri {uriPath = x},
      testProperty "queryL Lens on URI" $
        property $ do
          uri <- forAll genAbsoluteURIRef
          x <- forAll genQuery
          uri ^. queryL === uriQuery uri
          (uri & queryL .~ x) === uri {uriQuery = x},
      testProperty "fragmentL Lens on URI" $
        property $ do
          uri <- forAll genAbsoluteURIRef
          x <- forAll (Gen.maybe genBS)
          uri ^. fragmentL === uriFragment uri
          (uri & fragmentL .~ x) === uri {uriFragment = x},
      testProperty "authorityL Lens on relative ref" $
        property $ do
          rr <- forAll genRelativeURIRef
          x <- forAll (Gen.maybe genAuthority)
          (rr ^. authorityL === rrAuthority rr)
          (rr & authorityL .~ x) === rr {rrAuthority = x},
      testProperty "pathL Lens on relative ref" $
        property $ do
          rr <- forAll genRelativeURIRef
          x <- forAll genBS
          rr ^. pathL === rrPath rr
          (rr & pathL .~ x) === rr {rrPath = x},
      testProperty "queryL Lens on relative ref" $
        property $ do
          rr <- forAll genRelativeURIRef
          x <- forAll genQuery
          rr ^. queryL === rrQuery rr
          (rr & queryL .~ x) === rr {rrQuery = x},
      testProperty "fragmentL Lens on relative ref" $
        property $ do
          rr <- forAll genRelativeURIRef
          x <- forAll (Gen.maybe genBS)
          rr ^. fragmentL === rrFragment rr
          (rr & fragmentL .~ x) === rr {rrFragment = x}
    ]

-------------------------------------------------------------------------------
testParses :: ByteString -> URI -> TestTree
testParses = testParses' strictURIParserOptions

-------------------------------------------------------------------------------
testParseHost :: ByteString -> ByteString -> TestTree
testParseHost uri expectedHost =
  testParses uri $
    URI
      (Scheme "http")
      (Just (Authority Nothing (Host expectedHost) Nothing))
      mempty
      mempty
      Nothing

-------------------------------------------------------------------------------
testParsesLax :: ByteString -> URI -> TestTree
testParsesLax = testParses' laxURIParserOptions

-------------------------------------------------------------------------------
testParses' :: URIParserOptions -> ByteString -> URI -> TestTree
testParses' opts s u =
  testGroup
    "testParses'"
    [ parseTestURI opts s $ Right u,
      parseTestRelativeRef opts (makeRelativeRefBS s) $ Right (makeRelativeRefTyped u)
    ]

-------------------------------------------------------------------------------
makeRelativeRefTyped :: URI -> RelativeRef
makeRelativeRefTyped (URI _ a p q f) = RelativeRef a p q f

-------------------------------------------------------------------------------
makeRelativeRefBS :: ByteString -> ByteString
makeRelativeRefBS s = B8.tail x
  where
    (_, x) = B8.break (== ':') s

-------------------------------------------------------------------------------
testParseFailure :: ByteString -> URIParseError -> TestTree
testParseFailure s = parseTestURI strictURIParserOptions s . Left

-------------------------------------------------------------------------------
parseTestURI ::
  URIParserOptions ->
  ByteString ->
  Either URIParseError URI ->
  TestTree
parseTestURI opts s r = testCase (B8.unpack s) $ parseURI opts s @?= r

-------------------------------------------------------------------------------
roundtripTestURI ::
  URIParserOptions ->
  ByteString ->
  TestTree
roundtripTestURI opts s =
  testCase (B8.unpack s) $ (parseURI opts s >>= return . serializeURIRef') @?= Right s

-------------------------------------------------------------------------------
parseTestRelativeRef ::
  URIParserOptions ->
  ByteString ->
  Either URIParseError RelativeRef ->
  TestTree
parseTestRelativeRef opts s r =
  testCase (B8.unpack s) $ parseRelativeRef opts s @?= r

-------------------------------------------------------------------------------
serializeURITests :: TestTree
serializeURITests =
  testGroup
    "serializeURIRef"
    [ testCase "renders userinfo correctly" $ do
        let ui = UserInfo "user" "pass"
        let uri =
              URI
                (Scheme "http")
                (Just (Authority (Just ui) (Host "www.example.org") (Just port)))
                "/"
                (Query [("foo", "bar")])
                (Just "somefragment")
        let res = BB.toLazyByteString (serializeURIRef uri)
        res @?= "http://user:pass@www.example.org:123/?foo=bar#somefragment",
      testCase "encodes decoded paths" $ do
        let uri =
              URI
                (Scheme "http")
                (Just (Authority Nothing (Host "www.example.org") (Just port)))
                "/weird path"
                (Query [])
                Nothing
        let res = BB.toLazyByteString (serializeURIRef uri)
        res @?= "http://www.example.org:123/weird%20path",
      testCase "encodes relative refs" $ do
        let ui = UserInfo "user" "pass"
        let uri =
              RelativeRef
                (Just (Authority (Just ui) (Host "www.example.org") (Just port)))
                "/"
                (Query [("foo", "bar")])
                (Just "somefragment")
        let res = BB.toLazyByteString (serializeURIRef uri)
        res @?= "//user:pass@www.example.org:123/?foo=bar#somefragment"
    ]
  where
    port = Port 123

-------------------------------------------------------------------------------
normalizeURITests :: TestTree
normalizeURITests =
  testGroup
    "normalization"
    [ testCase "downcase schema" $ do
        normalizeURIBS o {unoDowncaseScheme = True} "hTtP://example.org"
          @?= "http://example.org",
      testCase "downcase host" $ do
        normalizeURIBS o {unoDowncaseHost = True} "http://ExAmPlE.org"
          @?= "http://example.org",
      testCase "drop default port http" $ do
        normalizeURIBS o {unoDropDefPort = True} "http://example.org:80"
          @?= "http://example.org",
      testCase "drop default port https" $ do
        normalizeURIBS o {unoDropDefPort = True} "https://example.org:443"
          @?= "https://example.org",
      testCase "drop default port no port" $ do
        normalizeURIBS o {unoDropDefPort = True} "http://example.org"
          @?= "http://example.org",
      testCase "drop default port nondefault" $ do
        normalizeURIBS o {unoDropDefPort = True} "http://example.org:8000"
          @?= "http://example.org:8000",
      testCase "drop default unknown schema" $ do
        normalizeURIBS o {unoDropDefPort = True} "bogus://example.org:9999"
          @?= "bogus://example.org:9999",
      testCase "user-extensable port defaulting hit" $ do
        normalizeURIBS
          o
            { unoDropDefPort = True,
              unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21)
            }
          "ftp://example.org:21"
          @?= "ftp://example.org",
      testCase "user-extensable port defaulting off" $ do
        normalizeURIBS
          o
            { unoDropDefPort = False,
              unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21)
            }
          "ftp://example.org:21"
          @?= "ftp://example.org:21",
      testCase "user-extensable port defaulting miss" $ do
        normalizeURIBS
          o
            { unoDropDefPort = True,
              unoDefaultPorts = M.singleton (Scheme "ftp") (Port 21)
            }
          "http://example.org:80"
          @?= "http://example.org:80",
      testCase "slash empty path" $ do
        normalizeURIBS o {unoSlashEmptyPath = True} "http://example.org"
          @?= "http://example.org/",
      testCase "slash empty path with nonempty path" $ do
        normalizeURIBS o {unoSlashEmptyPath = True} "http://example.org/foo/bar"
          @?= "http://example.org/foo/bar",
      testCase "drop redundant slashes" $ do
        normalizeURIBS o {unoDropExtraSlashes = True} "http://example.org/foo//bar///baz"
          @?= "http://example.org/foo/bar/baz",
      testCase "sort params" $ do
        normalizeURIBS o {unoSortParameters = True} "http://example.org/foo?zulu=1&charlie=&alpha=1"
          @?= "http://example.org/foo?alpha=1&charlie=&zulu=1",
      testCase "remove dot segments" $ do
        normalizeURIBS o {unoRemoveDotSegments = True} "http://example.org/a/b/c/./../../g"
          @?= "http://example.org/a/g",
      testCase "percent encoding is upcased automatically" $ do
        normalizeURIBS o "http://example.org/a?foo%3abar=baz"
          @?= "http://example.org/a?foo%3Abar=baz",
      testCase "aggressive normalization retains slashes (issue 41)" $ do
        normalizeURIBS aggressiveNormalization "http://example.org/"
          @?= "http://example.org/"
    ]
  where
    o = noNormalization
    normalizeURIBS opts bs = case parseURI laxURIParserOptions bs of
      Right x -> normalizeURIRef' opts x
      Left e -> error ("Test error, " <> show bs <> " did not parse: " <> show e)

trippingShow ::
  ( Show a,
    Read a,
    Eq a,
    MonadTest m
  ) =>
  a ->
  m ()
trippingShow a = tripping a show readMay
