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)
import Control.Applicative ((<|>), optional)
import Data.Data (Typeable)
import GHC.Generics (Generic)
data URI = URI
{ uriScheme :: !(Maybe Text)
, uriSlashes :: !Bool
, uriAuthority :: !URIAuth
, uriPath :: !(Vector Text)
, uriQuery :: !(Vector (Pair Text (Maybe Text)))
, uriFragment :: !(Maybe Text)
} deriving (Eq, Typeable, Generic)
printURI :: URI -> Text
printURI URI{..} =
maybe "" (<> ":") uriScheme
<> (if uriSlashes then "//" else "")
<> printURIAuth uriAuthority
<> "/" <> T.intercalate "/" (V.toList uriPath)
<> ( 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 = do
sch <- takeWhile1 (\c -> c `notElem` [':','/','@','.'])
_ <- char ':'
pure sch
parseSlashes = do
mS <- optional (string "//")
case mS of
P.Nothing -> pure False
P.Just _ -> pure True
parsePath =
( do void $ char '/'
V.fromList <$> parseChunkWithout ['/', '?', '=', '&', '#'] `sepBy` char '/'
) <|> pure V.empty
parseQuery :: Parser (Vector (Pair Text (Maybe Text)))
parseQuery =
( do void $ char '?'
let parse1 = do
k <- parseChunkWithout ['=','&','#']
mV <- ( Just <$> do void $ char '='
parseChunkWithout ['&','#']
) <|> pure Nothing
pure (k :!: mV)
qs <- parse1 `sepBy` char '&'
pure $ V.fromList qs
) <|> pure V.empty
parseFragment = do
void $ char '#'
parseChunkWithout []
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