{-# LANGUAGE
OverloadedStrings
, BangPatterns
, UnboxedTuples
, UnboxedSums
, MagicHash
, ScopedTypeVariables
, LambdaCase
, RecordWildCards
, NamedFieldPuns
, ApplicativeDo
, TemplateHaskell
#-}
module Url
(
Url(urlSerialization)
, ParseError(..)
, decodeUrl
, getScheme
, getUsername
, getAuthority
, getPassword
, getHost
, getPath
, getQuery
, getFragment
, getExtension
, getPort
, constructUrl
, literalUrl
) where
import Data.Bytes.Types (Bytes(..))
import Data.List (intercalate)
import Data.Word (Word16)
import GHC.Exts (Int(I#),(==#),Int#,int2Word#)
import GHC.Word (Word16(..))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (TExp(TExp))
import Url.Rebind (decodeUrl)
import Url.Unsafe (Url(..),ParseError(..))
import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Text.Latin1 as BytesL
getScheme :: Url -> Maybe Bytes
getScheme :: Url -> Maybe Bytes
getScheme Url{Bytes
urlSerialization :: Bytes
urlSerialization :: Url -> Bytes
urlSerialization,Int#
urlSchemeEnd :: Url -> Int#
urlSchemeEnd :: Int#
urlSchemeEnd} =
if Int# -> Int
I# Int#
urlSchemeEnd Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then Maybe Bytes
forall a. Maybe a
Nothing
else Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Bytes -> Maybe Bytes) -> Bytes -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ Int -> Bytes -> Bytes
Bytes.unsafeTake (Int# -> Int
I# Int#
urlSchemeEnd) Bytes
urlSerialization
getUsername :: Url -> Maybe Bytes
getUsername :: Url -> Maybe Bytes
getUsername Url{Bytes
urlSerialization :: Bytes
urlSerialization :: Url -> Bytes
urlSerialization,Int#
urlSchemeEnd :: Int#
urlSchemeEnd :: Url -> Int#
urlSchemeEnd,Int#
urlUsernameEnd :: Url -> Int#
urlUsernameEnd :: Int#
urlUsernameEnd,Int#
urlHostStart :: Url -> Int#
urlHostStart :: Int#
urlHostStart} =
case Int#
urlUsernameEnd Int# -> Int# -> Int#
==# Int#
urlHostStart of
Int#
0# -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Bytes -> Maybe Bytes) -> Bytes -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Bytes -> Bytes
unsafeSlice (Int# -> Int
I# Int#
urlSchemeEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Int# -> Int
I# Int#
urlUsernameEnd) Bytes
urlSerialization
Int#
_ -> Maybe Bytes
forall a. Maybe a
Nothing
getAuthority :: Url -> Maybe Bytes
getAuthority :: Url -> Maybe Bytes
getAuthority Url{Bytes
urlSerialization :: Bytes
urlSerialization :: Url -> Bytes
urlSerialization,Int#
urlSchemeEnd :: Int#
urlSchemeEnd :: Url -> Int#
urlSchemeEnd,Int#
urlUsernameEnd :: Int#
urlUsernameEnd :: Url -> Int#
urlUsernameEnd,Int#
urlHostStart :: Int#
urlHostStart :: Url -> Int#
urlHostStart} =
case Int#
urlUsernameEnd Int# -> Int# -> Int#
==# Int#
urlHostStart of
Int#
0# -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Bytes -> Maybe Bytes) -> Bytes -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Bytes -> Bytes
unsafeSlice (Int# -> Int
I# Int#
urlSchemeEnd Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) (Int# -> Int
I# Int#
urlHostStart Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bytes
urlSerialization
Int#
_ -> Maybe Bytes
forall a. Maybe a
Nothing
getPassword :: Url -> Maybe Bytes
getPassword :: Url -> Maybe Bytes
getPassword Url{Bytes
urlSerialization :: Bytes
urlSerialization :: Url -> Bytes
urlSerialization,Int#
urlUsernameEnd :: Int#
urlUsernameEnd :: Url -> Int#
urlUsernameEnd,Int#
urlHostStart :: Int#
urlHostStart :: Url -> Int#
urlHostStart} =
case Int#
urlUsernameEnd Int# -> Int# -> Int#
==# Int#
urlHostStart of
Int#
0# ->
let mpass :: Bytes
mpass = Int -> Int -> Bytes -> Bytes
unsafeSlice (Int# -> Int
I# Int#
urlUsernameEnd) (Int# -> Int
I# Int#
urlHostStart Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Bytes
urlSerialization
in case Bytes -> Maybe (Word8, Bytes)
Bytes.uncons Bytes
mpass of
Just (Word8
58,Bytes
password) -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
password
Maybe (Word8, Bytes)
_ -> Maybe Bytes
forall a. Maybe a
Nothing
Int#
_ -> Maybe Bytes
forall a. Maybe a
Nothing
getHost :: Url -> Maybe Bytes
getHost :: Url -> Maybe Bytes
getHost Url{Bytes
urlSerialization :: Bytes
urlSerialization :: Url -> Bytes
urlSerialization,Int#
urlHostStart :: Int#
urlHostStart :: Url -> Int#
urlHostStart,Int#
urlHostEnd :: Url -> Int#
urlHostEnd :: Int#
urlHostEnd} =
case Int#
urlHostStart Int# -> Int# -> Int#
==# Int#
urlHostEnd of
Int#
0# -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Bytes -> Maybe Bytes) -> Bytes -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Bytes -> Bytes
unsafeSlice (Int# -> Int
I# Int#
urlHostStart) (Int# -> Int
I# Int#
urlHostEnd) Bytes
urlSerialization
Int#
_ -> Maybe Bytes
forall a. Maybe a
Nothing
getPath :: Url -> Maybe Bytes
getPath :: Url -> Maybe Bytes
getPath Url{Bytes
urlSerialization :: Bytes
urlSerialization :: Url -> Bytes
urlSerialization,Int#
urlPathStart :: Url -> Int#
urlPathStart :: Int#
urlPathStart,Int#
urlQueryStart :: Url -> Int#
urlQueryStart :: Int#
urlQueryStart} =
case Int#
urlPathStart Int# -> Int# -> Int#
==# Int#
len of
Int#
0# -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Bytes -> Maybe Bytes) -> Bytes -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Bytes -> Bytes
unsafeSlice (Int# -> Int
I# Int#
urlPathStart) (Int# -> Int
I# Int#
urlQueryStart) Bytes
urlSerialization
Int#
_ -> Maybe Bytes
forall a. Maybe a
Nothing
where
!(I# Int#
len) = Bytes -> Int
Bytes.length Bytes
urlSerialization
getQuery :: Url -> Maybe Bytes
getQuery :: Url -> Maybe Bytes
getQuery Url{Bytes
urlSerialization :: Bytes
urlSerialization :: Url -> Bytes
urlSerialization,Int#
urlQueryStart :: Int#
urlQueryStart :: Url -> Int#
urlQueryStart,Int#
urlFragmentStart :: Url -> Int#
urlFragmentStart :: Int#
urlFragmentStart} =
case Int#
len Int# -> Int# -> Int#
==# Int#
urlQueryStart of
Int#
0# -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Bytes -> Maybe Bytes) -> Bytes -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Bytes -> Bytes
unsafeSlice (Int# -> Int
I# Int#
urlQueryStart) (Int# -> Int
I# Int#
urlFragmentStart) Bytes
urlSerialization
Int#
_ -> Maybe Bytes
forall a. Maybe a
Nothing
where
!(I# Int#
len) = Bytes -> Int
Bytes.length Bytes
urlSerialization
getFragment :: Url -> Maybe Bytes
getFragment :: Url -> Maybe Bytes
getFragment Url{Bytes
urlSerialization :: Bytes
urlSerialization :: Url -> Bytes
urlSerialization,Int#
urlFragmentStart :: Int#
urlFragmentStart :: Url -> Int#
urlFragmentStart} =
case Int#
len Int# -> Int# -> Int#
==# Int#
urlFragmentStart of
Int#
0# -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Bytes -> Maybe Bytes) -> Bytes -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Bytes -> Bytes
unsafeSlice (Int# -> Int
I# Int#
urlFragmentStart) (Int# -> Int
I# Int#
len) Bytes
urlSerialization
Int#
_ -> Maybe Bytes
forall a. Maybe a
Nothing
where
!(I# Int#
len) = Bytes -> Int
Bytes.length Bytes
urlSerialization
getPort :: Url -> Maybe Word16
getPort :: Url -> Maybe Word16
getPort Url{Int#
urlPort :: Url -> Int#
urlPort :: Int#
urlPort} =
case Int#
urlPort of
Int#
0x10000# -> Maybe Word16
forall a. Maybe a
Nothing
Int#
x -> Word16 -> Maybe Word16
forall a. a -> Maybe a
Just (Word16 -> Maybe Word16) -> Word16 -> Maybe Word16
forall a b. (a -> b) -> a -> b
$ Word# -> Word16
W16# (Int# -> Word#
int2Word# Int#
x)
getExtension :: Url -> Maybe Bytes
getExtension :: Url -> Maybe Bytes
getExtension Url
url = do
Bytes
path <- Url -> Maybe Bytes
getPath Url
url
if Bool -> Bool
not (Word8 -> Bytes -> Bool
Bytes.elem Word8
0x2e Bytes
path)
then Maybe Bytes
forall a. Maybe a
Nothing
else case Word8 -> Bytes -> [Bytes]
Bytes.split Word8
0x2e Bytes
path of
[] -> Maybe Bytes
forall a. Maybe a
Nothing
[Bytes]
xs -> Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (Bytes -> Maybe Bytes) -> Bytes -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ [Bytes] -> Bytes
forall a. [a] -> a
last [Bytes]
xs
{-# INLINE unsafeSlice #-}
unsafeSlice :: Int -> Int -> Bytes -> Bytes
unsafeSlice :: Int -> Int -> Bytes -> Bytes
unsafeSlice Int
begin Int
end (Bytes ByteArray
arr Int
_ Int
_) =
ByteArray -> Int -> Int -> Bytes
Bytes ByteArray
arr Int
begin (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
begin)
literalUrl :: String -> Q (TExp Url)
literalUrl :: String -> Q (TExp Url)
literalUrl String
ser = case Bytes -> Either ParseError Url
decodeUrl (Bytes -> Either ParseError Url) -> Bytes -> Either ParseError Url
forall a b. (a -> b) -> a -> b
$ String -> Bytes
BytesL.fromString String
ser of
Left ParseError
e -> String -> Q (TExp Url)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q (TExp Url)) -> String -> Q (TExp Url)
forall a b. (a -> b) -> a -> b
$ String
"Invalid url. Parse error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ParseError -> String
forall a. Show a => a -> String
show ParseError
e
Right Url{Int#
Bytes
urlFragmentStart :: Int#
urlQueryStart :: Int#
urlPathStart :: Int#
urlPort :: Int#
urlHostEnd :: Int#
urlHostStart :: Int#
urlUsernameEnd :: Int#
urlSchemeEnd :: Int#
urlSerialization :: Bytes
urlPort :: Url -> Int#
urlFragmentStart :: Url -> Int#
urlQueryStart :: Url -> Int#
urlPathStart :: Url -> Int#
urlHostEnd :: Url -> Int#
urlHostStart :: Url -> Int#
urlUsernameEnd :: Url -> Int#
urlSchemeEnd :: Url -> Int#
urlSerialization :: Url -> Bytes
..} -> do
TExp Url -> Q (TExp Url)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TExp Url -> Q (TExp Url)) -> TExp Url -> Q (TExp Url)
forall a b. (a -> b) -> a -> b
$ Exp -> TExp Url
forall a. Exp -> TExp a
TExp (Exp -> TExp Url) -> Exp -> TExp Url
forall a b. (a -> b) -> a -> b
$
Name -> Exp
ConE 'Url
Exp -> Exp -> Exp
`AppE` (Exp -> Exp
ParensE (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Exp
VarE 'BytesL.fromString) Exp -> Exp -> Exp
`AppE` (Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
ser))
Exp -> Exp -> Exp
`AppE` Int# -> Exp
liftInt# Int#
urlSchemeEnd
Exp -> Exp -> Exp
`AppE` Int# -> Exp
liftInt# Int#
urlUsernameEnd
Exp -> Exp -> Exp
`AppE` Int# -> Exp
liftInt# Int#
urlHostStart
Exp -> Exp -> Exp
`AppE` Int# -> Exp
liftInt# Int#
urlHostEnd
Exp -> Exp -> Exp
`AppE` Int# -> Exp
liftInt# Int#
urlPort
Exp -> Exp -> Exp
`AppE` Int# -> Exp
liftInt# Int#
urlPathStart
Exp -> Exp -> Exp
`AppE` Int# -> Exp
liftInt# Int#
urlQueryStart
Exp -> Exp -> Exp
`AppE` Int# -> Exp
liftInt# Int#
urlFragmentStart
where
liftInt# :: Int# -> Exp
liftInt# :: Int# -> Exp
liftInt# Int#
x = Lit -> Exp
LitE (Integer -> Lit
IntPrimL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ Int# -> Int
I# Int#
x))
constructUrl ::
Maybe String
-> String
-> Maybe Word16
-> String
-> [(String,String)]
-> Maybe String
-> Q (TExp Url)
constructUrl :: Maybe String
-> String
-> Maybe Word16
-> String
-> [(String, String)]
-> Maybe String
-> Q (TExp Url)
constructUrl Maybe String
mscheme String
host Maybe Word16
mport String
path [(String, String)]
qps Maybe String
mfrag = String -> Q (TExp Url)
literalUrl String
ser
where
ser :: String
ser = String
scheme String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
host String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
port String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
path String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
rqps String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
frag
scheme :: String
scheme = case Maybe String
mscheme of
Maybe String
Nothing -> String
forall a. Monoid a => a
mempty
Just String
x -> String
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"://"
port :: String
port = case Maybe Word16
mport of
Maybe Word16
Nothing -> String
forall a. Monoid a => a
mempty
Just Word16
x -> Char
':' Char -> String -> String
forall a. a -> [a] -> [a]
: Word16 -> String
forall a. Show a => a -> String
show Word16
x
rqps :: String
rqps :: String
rqps = String
"?" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"&" (((String, String) -> String) -> [(String, String)] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(String
a,String
b) -> String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"=" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
b) [(String, String)]
qps)
frag :: String
frag = case Maybe String
mfrag of
Maybe String
Nothing -> String
forall a. Monoid a => a
mempty
Just String
x -> String
"#" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
x