{-# 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 (Show, Eq, Typeable, Generic)
instance Arbitrary DirOrFile where
arbitrary = oneof [pure Dir, pure File]
data URI = URI
{ uriScheme :: !(Maybe Text) -- ^ the scheme without the colon - @https://hackage.haskell.org/@ has a scheme of @https@
, uriSlashes :: !Bool -- ^ are the slashes present? - @https://hackage.haskell.org/@ is @True@
, uriAuthority :: !URIAuth
, uriPath :: !(Maybe (Vector Text, DirOrFile)) -- ^ slash-separated list - @https://hackage.haskell.org/foo@ is @["foo"]@, second value is if the path has a trailing slash
, uriQuery :: !(Vector (Pair Text (Maybe Text))) -- ^ list of key-value pairs - @https://hackage.haskell.org/?foo=bar&baz&qux=@ is
-- @[("foo", Just "bar"), ("baz", Nothing), ("qux", Just "")]@
, uriFragment :: !(Maybe Text) -- ^ uri suffix - @https://hackage.haskell.org/#some-header@ is @Just "some-header"@
} deriving (Show, Eq, Typeable, Generic)
instance Arbitrary URI where
arbitrary = do
auth <- arbitrary
scheme <- if isJust (uriAuthPassword auth)
then Just <$> arbitraryNonEmptyText
else arbitraryScheme
slashes <- arbitrary
path <- arbitraryPath
query <- arbitraryQuery
fragment <- arbitraryScheme
pure $ URI scheme slashes auth path query fragment
where
arbitraryScheme = oneof [pure Nothing, Just <$> arbitraryNonEmptyText]
arbitraryNonEmptyText = T.pack <$> listOf1 (elements ['a' .. 'z'])
arbitraryPath =
oneof
[ pure Nothing
, do
xs <- V.fromList <$> listOf1 arbitraryNonEmptyText
y <- arbitrary
pure $ Just (xs, y)
]
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, f) -> "/" <> T.intercalate "/" (V.toList xs) <> (if f == Dir && not (null xs) then "/" else "")
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, DirOrFile))
parsePath =
let withRoot = do
void (char '/') <?> "root"
(
do
xs <- V.fromList <$> parseChunkWithout ['/', '?', '=', '&', '#'] `sepBy` char '/'
pure . Just $
if not (null xs) && V.last xs == ""
then (V.init xs, Dir)
else (xs, File)
) <?> "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