1-- |
2-- Module      :  Text.URI.Parser.Text
3-- Copyright   :  © 2017–present Mark Karpov
4-- License     :  BSD 3 clause
5--
6-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
7-- Stability   :  experimental
8-- Portability :  portable
9--
10-- URI parser for strict 'Text', an internal module.
11
12{-# LANGUAGE DataKinds         #-}
13{-# LANGUAGE FlexibleContexts  #-}
14{-# LANGUAGE OverloadedStrings #-}
15{-# LANGUAGE RankNTypes        #-}
16{-# LANGUAGE RecordWildCards   #-}
17
18module Text.URI.Parser.Text
19  ( mkURI
20  , parser )
21where
22
23import Control.Monad
24import Control.Monad.Catch (MonadThrow (..))
25import Control.Monad.State.Strict
26import Data.List.NonEmpty (NonEmpty (..))
27import Data.Maybe (isJust, catMaybes)
28import Data.Text (Text)
29import Data.Void
30import Text.Megaparsec
31import Text.Megaparsec.Char
32import Text.URI.Parser.Text.Utils
33import Text.URI.Types
34import qualified Data.ByteString.Char8      as B8
35import qualified Data.List.NonEmpty         as NE
36import qualified Data.Text.Encoding         as TE
37import qualified Text.Megaparsec.Char.Lexer as L
38
39-- | Construct a 'URI' from 'Text'. The input you pass to 'mkURI' must be a
40-- valid URI as per RFC 3986, that is, its components should be
41-- percent-encoded where necessary. In case of parse failure
42-- 'ParseException' is thrown.
43--
44-- This function uses the 'parser' parser under the hood, which you can also
45-- use directly in a Megaparsec parser.
46
47mkURI :: MonadThrow m => Text -> m URI
48mkURI input =
49  case runParser (parser <* eof :: Parsec Void Text URI) "" input of
50    Left  b -> throwM (ParseException b)
51    Right x -> return x
52
53-- | This parser can be used to parse 'URI' from strict 'Text'. Remember to
54-- use a concrete non-polymorphic parser type for efficiency.
55
56parser :: MonadParsec e Text m => m URI
57parser = do
58  uriScheme          <- optional (try pScheme)
59  mauth              <- optional pAuthority
60  (absPath, uriPath) <- pPath (isJust mauth)
61  uriQuery           <- option [] pQuery
62  uriFragment        <- optional pFragment
63  let uriAuthority = maybe (Left absPath) Right mauth
64  return URI {..}
65{-# INLINEABLE parser #-}
66{-# SPECIALIZE parser :: Parsec Void Text URI #-}
67
68pScheme :: MonadParsec e Text m => m (RText 'Scheme)
69pScheme = do
70  x  <- asciiAlphaChar
71  xs <- many (asciiAlphaNumChar <|> char '+' <|> char '-' <|> char '.')
72  void (char ':')
73  liftR mkScheme (x:xs)
74{-# INLINE pScheme #-}
75
76pAuthority :: MonadParsec e Text m => m Authority
77pAuthority = do
78  void (string "//")
79  authUserInfo <- optional pUserInfo
80  authHost <- pHost True >>= liftR mkHost
81  authPort <- optional (char ':' *> L.decimal)
82  return Authority {..}
83{-# INLINE pAuthority #-}
84
85pUserInfo :: MonadParsec e Text m => m UserInfo
86pUserInfo = try $ do
87  uiUsername <- label "username" $
88    many (unreservedChar <|> percentEncChar <|> subDelimChar)
89      >>= liftR mkUsername
90  uiPassword <- optional $ do
91    void (char ':')
92    many (unreservedChar <|> percentEncChar <|> subDelimChar <|> char ':')
93      >>= liftR mkPassword
94  void (char '@')
95  return UserInfo {..}
96{-# INLINE pUserInfo #-}
97
98pPath :: MonadParsec e Text m
99  => Bool
100  -> m (Bool, Maybe (Bool, NonEmpty (RText 'PathPiece)))
101pPath hasAuth = do
102  doubleSlash <- lookAhead (option False (True <$ string "//"))
103  when (doubleSlash && not hasAuth) $
104    (unexpected . Tokens . NE.fromList) "//"
105  absPath <- option False (True <$ char '/')
106  (rawPieces, trailingSlash) <- flip runStateT False $
107    flip sepBy (char '/') . label "path piece" $ do
108      x <- many pchar
109      put (null x)
110      return x
111  pieces <- mapM (liftR mkPathPiece) (filter (not . null) rawPieces)
112  return
113    ( absPath
114    , case NE.nonEmpty pieces of
115        Nothing -> Nothing
116        Just ps -> Just (trailingSlash, ps)
117    )
118{-# INLINE pPath #-}
119
120pQuery :: MonadParsec e Text m => m [QueryParam]
121pQuery = do
122  void (char '?')
123  void (optional (char '&'))
124  fmap catMaybes . flip sepBy (char '&') . label "query parameter" $ do
125    let p = many (pchar' <|> char '/' <|> char '?')
126    k' <- p
127    mv <- optional (char '=' *> p)
128    k  <- liftR mkQueryKey k'
129    if null k'
130      then return Nothing
131      else Just <$> case mv of
132             Nothing -> return (QueryFlag k)
133             Just v  -> QueryParam k <$> liftR mkQueryValue v
134{-# INLINE pQuery #-}
135
136pFragment :: MonadParsec e Text m => m (RText 'Fragment)
137pFragment = do
138  void (char '#')
139  xs <- many . label "fragment character" $
140    pchar <|> char '/' <|> char '?'
141  liftR mkFragment xs
142{-# INLINE pFragment #-}
143
144----------------------------------------------------------------------------
145-- Helpers
146
147liftR :: MonadParsec e s m
148  => (forall n. MonadThrow n => Text -> n r)
149  -> String
150  -> m r
151liftR f = maybe empty return . f . TE.decodeUtf8 . B8.pack
152{-# INLINE liftR #-}
153