{-# 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.Word (Word16)
import Data.Bytes.Types (Bytes(..))
import Url.Rebind (decodeUrl)
import Url.Unsafe (Url(..),ParseError(..))
import GHC.Exts (Int(I#),(==#),Int#,int2Word#)
import GHC.Word (Word16(..))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (TExp(TExp))
import Data.List (intercalate)
import qualified Data.Bytes as Bytes
getScheme :: Url -> Maybe Bytes
getScheme Url{urlSerialization,urlSchemeEnd} =
if I# urlSchemeEnd == 0
then Nothing
else Just $ Bytes.unsafeTake (I# urlSchemeEnd) urlSerialization
getUsername :: Url -> Maybe Bytes
getUsername Url{urlSerialization,urlSchemeEnd,urlUsernameEnd,urlHostStart} =
case urlUsernameEnd ==# urlHostStart of
0# -> Just $ unsafeSlice (I# urlSchemeEnd + 3) (I# urlUsernameEnd) urlSerialization
_ -> Nothing
getAuthority :: Url -> Maybe Bytes
getAuthority Url{urlSerialization,urlSchemeEnd,urlUsernameEnd,urlHostStart} =
case urlUsernameEnd ==# urlHostStart of
0# -> Just $ unsafeSlice (I# urlSchemeEnd + 3) (I# urlHostStart - 1) urlSerialization
_ -> Nothing
getPassword :: Url -> Maybe Bytes
getPassword Url{urlSerialization,urlUsernameEnd,urlHostStart} =
case urlUsernameEnd ==# urlHostStart of
0# ->
let mpass = unsafeSlice (I# urlUsernameEnd) (I# urlHostStart - 1) urlSerialization
in case Bytes.uncons mpass of
Just (58,password) -> Just password
_ -> Nothing
_ -> Nothing
getHost :: Url -> Maybe Bytes
getHost Url{urlSerialization,urlHostStart,urlHostEnd} =
case urlHostStart ==# urlHostEnd of
0# -> Just $ unsafeSlice (I# urlHostStart) (I# urlHostEnd) urlSerialization
_ -> Nothing
getPath :: Url -> Maybe Bytes
getPath Url{urlSerialization,urlPathStart,urlQueryStart} =
case urlPathStart ==# len of
0# -> Just $ unsafeSlice (I# urlPathStart) (I# urlQueryStart) urlSerialization
_ -> Nothing
where
!(I# len) = Bytes.length urlSerialization
getQuery :: Url -> Maybe Bytes
getQuery Url{urlSerialization,urlQueryStart,urlFragmentStart} =
case len ==# urlQueryStart of
0# -> Just $ unsafeSlice (I# urlQueryStart) (I# urlFragmentStart) urlSerialization
_ -> Nothing
where
!(I# len) = Bytes.length urlSerialization
getFragment :: Url -> Maybe Bytes
getFragment Url{urlSerialization,urlFragmentStart} =
case len ==# urlFragmentStart of
0# -> Just $ unsafeSlice (I# urlFragmentStart) (I# len) urlSerialization
_ -> Nothing
where
!(I# len) = Bytes.length urlSerialization
getPort :: Url -> Maybe Word16
getPort Url{urlPort} =
case urlPort of
0x10000# -> Nothing
x -> Just $ W16# (int2Word# x)
getExtension :: Url -> Maybe Bytes
getExtension url = do
path <- getPath url
if not (Bytes.elem 0x2e path)
then Nothing
else case Bytes.split 0x2e path of
[] -> Nothing
xs -> Just $ last xs
{-# INLINE unsafeSlice #-}
unsafeSlice :: Int -> Int -> Bytes -> Bytes
unsafeSlice begin end (Bytes arr _ _) =
Bytes arr begin (end - begin)
literalUrl :: String -> Q (TExp Url)
literalUrl ser = case decodeUrl $ Bytes.fromLatinString ser of
Left e -> fail $ "Invalid url. Parse error: " <> show e
Right Url{..} -> do
pure $ TExp $
ConE 'Url
`AppE` (ParensE $ (VarE 'Bytes.fromLatinString) `AppE` (LitE $ StringL ser))
`AppE` (liftInt# urlSchemeEnd)
`AppE` (liftInt# urlUsernameEnd)
`AppE` (liftInt# urlHostStart)
`AppE` (liftInt# urlHostEnd)
`AppE` (liftInt# urlPort)
`AppE` (liftInt# urlPathStart)
`AppE` (liftInt# urlQueryStart)
`AppE` (liftInt# urlFragmentStart)
where
liftInt# :: Int# -> Exp
liftInt# x = LitE (IntPrimL (fromIntegral $ I# x))
constructUrl ::
Maybe String
-> String
-> Maybe Word16
-> String
-> [(String,String)]
-> Maybe String
-> Q (TExp Url)
constructUrl mscheme host mport path qps mfrag = literalUrl ser
where
ser = scheme <> host <> port <> path <> rqps <> frag
scheme = case mscheme of
Nothing -> mempty
Just x -> x <> "://"
port = case mport of
Nothing -> mempty
Just x -> ':' : show x
rqps :: String
rqps = "?" <> (intercalate "&" $ fmap (\(a,b) -> a <> "=" <> b) qps)
frag = case mfrag of
Nothing -> mempty
Just x -> "#" <> x