{-# LANGUAGE
    OverloadedStrings
  , BangPatterns
  , UnboxedTuples
  , UnboxedSums
  , MagicHash
  , ScopedTypeVariables
  , LambdaCase
  , RecordWildCards
  , NamedFieldPuns
  , ApplicativeDo
  , TemplateHaskell
#-}

-- | Note: this library parses, but does not validate urls
module Url 
  ( -- * Types
    Url(urlSerialization)
  , ParseError(..)
    -- * Parsing
  , decodeUrl
    -- * Slicing
  , 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

-- | Slice into the 'Url' and retrieve the scheme, if it's present
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

-- | Slice into the 'Url' and retrieve the username, if it's present
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

-- | Slice into the 'Url' and retrieve the host, if it's present
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

-- | Slice into the 'Url' and retrieve the path starting with @\'/'@, if it's present
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

-- | Slice into the 'Url' and retrieve the query string starting with @\'?'@, if it's present
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

-- | Slice into the 'Url' and retrieve the fragment starting with @\'#'@, if it's present
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)

-- | This function is intentionally imprecise. 
-- E.g. @getExtension "google.com/facebook.com" == Just ".com"@
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 -- ^ scheme
  -> String -- ^ host
  -> Maybe Word16 -- ^ port
  -> String -- ^ path
  -> [(String,String)] -- query string params
  -> Maybe String -- ^ framgent
  -> 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