{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Data.URI where
import Data.URI.Auth (URIAuth (uriAuthPassword),
parseURIAuth, printURIAuth)
import Control.Applicative (optional, (<|>))
import Control.Monad (void, when)
import Data.Attoparsec.Text (Parser, char, sepBy, string,
takeWhile, takeWhile1, (<?>))
import Data.Char (isControl, isSpace)
import Data.Strict.Maybe (Maybe (..), isJust, maybe)
import Data.Strict.Tuple (Pair (..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import Prelude hiding (Maybe (..), maybe, takeWhile)
import qualified Prelude as P
import Data.Data (Typeable)
import GHC.Generics (Generic)
import Test.QuickCheck (Arbitrary (..))
import Test.QuickCheck.Gen (elements, listOf, listOf1, oneof)
import Test.QuickCheck.Instances ()
data DirOrFile = Dir | File
deriving (Int -> DirOrFile -> ShowS
[DirOrFile] -> ShowS
DirOrFile -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DirOrFile] -> ShowS
$cshowList :: [DirOrFile] -> ShowS
show :: DirOrFile -> String
$cshow :: DirOrFile -> String
showsPrec :: Int -> DirOrFile -> ShowS
$cshowsPrec :: Int -> DirOrFile -> ShowS
Show, DirOrFile -> DirOrFile -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DirOrFile -> DirOrFile -> Bool
$c/= :: DirOrFile -> DirOrFile -> Bool
== :: DirOrFile -> DirOrFile -> Bool
$c== :: DirOrFile -> DirOrFile -> Bool
Eq, Typeable, forall x. Rep DirOrFile x -> DirOrFile
forall x. DirOrFile -> Rep DirOrFile x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DirOrFile x -> DirOrFile
$cfrom :: forall x. DirOrFile -> Rep DirOrFile x
Generic)
instance Arbitrary DirOrFile where
arbitrary :: Gen DirOrFile
arbitrary = forall a. [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure DirOrFile
Dir, forall (f :: * -> *) a. Applicative f => a -> f a
pure DirOrFile
File]
data URI = URI
{ URI -> Maybe Text
uriScheme :: !(Maybe Text)
, URI -> Bool
uriSlashes :: !Bool
, URI -> URIAuth
uriAuthority :: !URIAuth
, URI -> Maybe (Vector Text, DirOrFile)
uriPath :: !(Maybe (Vector Text, DirOrFile))
, URI -> Vector (Pair Text (Maybe Text))
uriQuery :: !(Vector (Pair Text (Maybe Text)))
, URI -> Maybe Text
uriFragment :: !(Maybe Text)
} deriving (Int -> URI -> ShowS
[URI] -> ShowS
URI -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [URI] -> ShowS
$cshowList :: [URI] -> ShowS
show :: URI -> String
$cshow :: URI -> String
showsPrec :: Int -> URI -> ShowS
$cshowsPrec :: Int -> URI -> ShowS
Show, URI -> URI -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URI -> URI -> Bool
$c/= :: URI -> URI -> Bool
== :: URI -> URI -> Bool
$c== :: URI -> URI -> Bool
Eq, Typeable, forall x. Rep URI x -> URI
forall x. URI -> Rep URI x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep URI x -> URI
$cfrom :: forall x. URI -> Rep URI x
Generic)
instance Arbitrary URI where
arbitrary :: Gen URI
arbitrary = do
URIAuth
auth <- forall a. Arbitrary a => Gen a
arbitrary
Maybe Text
scheme <- if forall a. Maybe a -> Bool
isJust (URIAuth -> Maybe Text
uriAuthPassword URIAuth
auth)
then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
arbitraryNonEmptyText
else Gen (Maybe Text)
arbitraryScheme
Bool
slashes <- forall a. Arbitrary a => Gen a
arbitrary
Maybe (Vector Text, DirOrFile)
path <- Gen (Maybe (Vector Text, DirOrFile))
arbitraryPath
Vector (Pair Text (Maybe Text))
query <- Gen (Vector (Pair Text (Maybe Text)))
arbitraryQuery
Maybe Text
fragment <- Gen (Maybe Text)
arbitraryScheme
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Maybe Text
-> Bool
-> URIAuth
-> Maybe (Vector Text, DirOrFile)
-> Vector (Pair Text (Maybe Text))
-> Maybe Text
-> URI
URI Maybe Text
scheme Bool
slashes URIAuth
auth Maybe (Vector Text, DirOrFile)
path Vector (Pair Text (Maybe Text))
query Maybe Text
fragment
where
arbitraryScheme :: Gen (Maybe Text)
arbitraryScheme = forall a. [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
arbitraryNonEmptyText]
arbitraryNonEmptyText :: Gen Text
arbitraryNonEmptyText = String -> Text
T.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf1 (forall a. [a] -> Gen a
elements [Char
'a' .. Char
'z'])
arbitraryPath :: Gen (Maybe (Vector Text, DirOrFile))
arbitraryPath =
forall a. [Gen a] -> Gen a
oneof
[ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
, do
Vector Text
xs <- forall a. [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf1 Gen Text
arbitraryNonEmptyText
DirOrFile
y <- forall a. Arbitrary a => Gen a
arbitrary
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Vector Text
xs, DirOrFile
y)
]
arbitraryQuery :: Gen (Vector (Pair Text (Maybe Text)))
arbitraryQuery =
forall a. [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Gen a -> Gen [a]
listOf Gen (Pair Text (Maybe Text))
go
where
go :: Gen (Pair Text (Maybe Text))
go = do
Text
a <- Gen Text
arbitraryNonEmptyText
Maybe Text
mb <- forall a. [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing, forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Text
arbitraryNonEmptyText]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
a forall a b. a -> b -> Pair a b
:!: Maybe Text
mb)
printURI :: URI -> Text
printURI :: URI -> Text
printURI URI{Bool
Maybe (Vector Text, DirOrFile)
Maybe Text
Vector (Pair Text (Maybe Text))
URIAuth
uriFragment :: Maybe Text
uriQuery :: Vector (Pair Text (Maybe Text))
uriPath :: Maybe (Vector Text, DirOrFile)
uriAuthority :: URIAuth
uriSlashes :: Bool
uriScheme :: Maybe Text
uriFragment :: URI -> Maybe Text
uriQuery :: URI -> Vector (Pair Text (Maybe Text))
uriPath :: URI -> Maybe (Vector Text, DirOrFile)
uriAuthority :: URI -> URIAuth
uriSlashes :: URI -> Bool
uriScheme :: URI -> Maybe Text
..} =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (forall a. Semigroup a => a -> a -> a
<> Text
":") Maybe Text
uriScheme
forall a. Semigroup a => a -> a -> a
<> (if Bool
uriSlashes then Text
"//" else Text
"")
forall a. Semigroup a => a -> a -> a
<> URIAuth -> Text
printURIAuth URIAuth
uriAuthority
forall a. Semigroup a => a -> a -> a
<> ( case Maybe (Vector Text, DirOrFile)
uriPath of
Just (Vector Text
xs, DirOrFile
f) -> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" (forall a. Vector a -> [a]
V.toList Vector Text
xs) forall a. Semigroup a => a -> a -> a
<> (if DirOrFile
f forall a. Eq a => a -> a -> Bool
== DirOrFile
Dir Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector Text
xs) then Text
"/" else Text
"")
Maybe (Vector Text, DirOrFile)
Nothing -> Text
""
)
forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector (Pair Text (Maybe Text))
uriQuery
then Text
""
else Text
"?"
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"&"
( forall a. Vector a -> [a]
V.toList forall a b. (a -> b) -> a -> b
$
(\(Text
k :!: Maybe Text
mV) ->
let v' :: Text
v' = case Maybe Text
mV of
Maybe Text
Nothing -> Text
""
Just Text
v -> Text
"=" forall a. Semigroup a => a -> a -> a
<> Text
v
in Text
k forall a. Semigroup a => a -> a -> a
<> Text
v'
) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector (Pair Text (Maybe Text))
uriQuery
)
)
forall a. Semigroup a => a -> a -> a
<> case Maybe Text
uriFragment of
Maybe Text
Nothing -> Text
""
Just Text
f -> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
f
parseURI :: Parser URI
parseURI :: Parser URI
parseURI =
Maybe Text
-> Bool
-> URIAuth
-> Maybe (Vector Text, DirOrFile)
-> Vector (Pair Text (Maybe Text))
-> Maybe Text
-> URI
URI forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall {a}. Maybe a -> Maybe a
toStrictMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
parseScheme)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
parseSlashes
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser URIAuth
parseURIAuth
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe (Vector Text, DirOrFile))
parsePath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Vector (Pair Text (Maybe Text)))
parseQuery
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall {a}. Maybe a -> Maybe a
toStrictMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Text
parseFragment)
where
parseScheme :: Parser Text
parseScheme :: Parser Text
parseScheme = do
Text
sch <- (Char -> Bool) -> Parser Text
takeWhile1 (\Char
c -> Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
':',Char
'/',Char
'@',Char
'.',Char
'[',Char
'*']) forall i a. Parser i a -> String -> Parser i a
<?> String
"scheme value"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
sch forall a. Eq a => a -> a -> Bool
== Text
"localhost") (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"can't be localhost")
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
':') forall i a. Parser i a -> String -> Parser i a
<?> String
"scheme colon"
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
sch
parseSlashes :: Parser Bool
parseSlashes :: Parser Bool
parseSlashes = do
Maybe Text
mS <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Parser Text
string Text
"//") forall i a. Parser i a -> String -> Parser i a
<?> String
"slashes"
case Maybe Text
mS of
Maybe Text
P.Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
P.Just Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
parsePath :: Parser (Maybe (Vector Text, DirOrFile))
parsePath :: Parser (Maybe (Vector Text, DirOrFile))
parsePath =
let withRoot :: Parser (Maybe (Vector Text, DirOrFile))
withRoot = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'/') forall i a. Parser i a -> String -> Parser i a
<?> String
"root"
(
do
Vector Text
xs <- forall a. [a] -> Vector a
V.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser Text
parseChunkWithout [Char
'/', Char
'?', Char
'=', Char
'&', Char
'#'] forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser Char
char Char
'/'
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Vector Text
xs) Bool -> Bool -> Bool
&& forall a. Vector a -> a
V.last Vector Text
xs forall a. Eq a => a -> a -> Bool
== Text
""
then (forall a. Vector a -> Vector a
V.init Vector Text
xs, DirOrFile
Dir)
else (Vector Text
xs, DirOrFile
File)
) forall i a. Parser i a -> String -> Parser i a
<?> String
"path"
withoutRoot :: Parser i (Maybe a)
withoutRoot = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing forall i a. Parser i a -> String -> Parser i a
<?> String
"empty path"
in Parser (Maybe (Vector Text, DirOrFile))
withRoot forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {i} {a}. Parser i (Maybe a)
withoutRoot
parseQuery :: Parser (Vector (Pair Text (Maybe Text)))
parseQuery :: Parser (Vector (Pair Text (Maybe Text)))
parseQuery =
( do forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'?') forall i a. Parser i a -> String -> Parser i a
<?> String
"uri query init"
let parse1 :: Parser Text (Pair Text (Maybe Text))
parse1 = do
Text
k <- String -> Parser Text
parseChunkWithout [Char
'=',Char
'&',Char
'#'] forall i a. Parser i a -> String -> Parser i a
<?> String
"uri query key"
Maybe Text
mV <- ( forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'=') forall i a. Parser i a -> String -> Parser i a
<?> String
"uri query sep"
String -> Parser Text
parseChunkWithout [Char
'&',Char
'#'] forall i a. Parser i a -> String -> Parser i a
<?> String
"uri query val"
) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
k forall a b. a -> b -> Pair a b
:!: Maybe Text
mV)
[Pair Text (Maybe Text)]
qs <- Parser Text (Pair Text (Maybe Text))
parse1 forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser Char
char Char
'&' forall i a. Parser i a -> String -> Parser i a
<?> String
"query params"
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. [a] -> Vector a
V.fromList [Pair Text (Maybe Text)]
qs)
) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Vector a
V.empty
parseFragment :: Parser Text
parseFragment :: Parser Text
parseFragment = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser Char
char Char
'#') forall i a. Parser i a -> String -> Parser i a
<?> String
"fragment init"
String -> Parser Text
parseChunkWithout [] forall i a. Parser i a -> String -> Parser i a
<?> String
"fragment value"
parseChunkWithout :: [Char] -> Parser Text
parseChunkWithout :: String -> Parser Text
parseChunkWithout String
xs =
(Char -> Bool) -> Parser Text
takeWhile (\Char
c -> Bool -> Bool
not (Char -> Bool
isControl Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
&& Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
xs)
toStrictMaybe :: Maybe a -> Maybe a
toStrictMaybe Maybe a
P.Nothing = forall a. Maybe a
Nothing
toStrictMaybe (P.Just a
x) = forall a. a -> Maybe a
Just a
x