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