{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.URI.Arbitrary
()
where
import Control.Applicative ( (<$>)
, (<*>)
)
import Control.Monad ( replicateM )
import Data.List ( intercalate )
import Network.URI ( parseURIReference
, URI(..)
, URIAuth(..)
, uriToString
)
import Test.QuickCheck ( Arbitrary(arbitrary, shrink)
, choose
, elements
, Gen
, listOf
, listOf1
, oneof
, suchThat
)
instance Arbitrary URI where
arbitrary = do
uriScheme <- 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)
]
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
]
return $ "[" ++ x ++ "]"
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 ['!', '$', '&', '\'', '(', ')', '*', '+', ',', ';', '=']
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']]