module Happstack.Server.SURI.ParseURI(parseURIRef) where

import qualified Data.ByteString          as BB
import qualified Data.ByteString.Internal as BB
import qualified Data.ByteString.Unsafe   as BB
import Data.ByteString.Char8 as BC
import Prelude hiding(break,length,null,drop,splitAt)
import Network.URI

-- import Happstack.Util.ByteStringCompat

parseURIRef :: ByteString -> URI
parseURIRef :: ByteString -> URI
parseURIRef ByteString
fs =
  case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
break (\Char
c -> Char
':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
|| Char
'/' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
|| Char
'?' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
|| Char
'#' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) ByteString
fs of
  (ByteString
initial,ByteString
rest) ->
      let ui :: [Char]
ui = ByteString -> [Char]
unpack ByteString
initial
      in case ByteString -> Maybe (Char, ByteString)
uncons ByteString
rest of
         Maybe (Char, ByteString)
Nothing ->
             if ByteString -> Bool
null ByteString
initial then URI
nullURI -- empty uri
                             else -- uri not containing either ':' or '/'
                                  URI
nullURI { uriPath :: [Char]
uriPath = [Char]
ui }
         Just (Char
c, ByteString
rrest) ->
             case Char
c of
             Char
':' -> ByteString
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI) -> URI
forall b.
ByteString
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b) -> b
pabsuri   ByteString
rrest ((Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI) -> URI)
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI) -> URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI (ByteString -> [Char]
unpack ByteString
initial)
             Char
'/' -> ByteString -> ([Char] -> [Char] -> [Char] -> URI) -> URI
forall b. ByteString -> ([Char] -> [Char] -> [Char] -> b) -> b
puriref   ByteString
fs    (([Char] -> [Char] -> [Char] -> URI) -> URI)
-> ([Char] -> [Char] -> [Char] -> URI) -> URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI [Char]
"" Maybe URIAuth
forall a. Maybe a
Nothing
             Char
'?' -> ByteString -> ([Char] -> [Char] -> URI) -> URI
forall t. ByteString -> ([Char] -> [Char] -> t) -> t
pquery    ByteString
rrest (([Char] -> [Char] -> URI) -> URI)
-> ([Char] -> [Char] -> URI) -> URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI [Char]
"" Maybe URIAuth
forall a. Maybe a
Nothing [Char]
ui
             Char
'#' -> ByteString -> ([Char] -> URI) -> URI
forall b. ByteString -> ([Char] -> b) -> b
pfragment ByteString
rrest (([Char] -> URI) -> URI) -> ([Char] -> URI) -> URI
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe URIAuth -> [Char] -> [Char] -> [Char] -> URI
URI [Char]
"" Maybe URIAuth
forall a. Maybe a
Nothing [Char]
ui [Char]
""
             Char
_   -> [Char] -> URI
forall a. HasCallStack => [Char] -> a
error [Char]
"parseURIRef: Can't happen"

pabsuri :: ByteString
           -> (Maybe URIAuth -> String -> String -> String -> b)
           -> b
pabsuri :: ByteString
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b) -> b
pabsuri ByteString
fs Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b
cont =
  if ByteString -> Int
length ByteString
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& ByteString -> Char
unsafeHead ByteString
fs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' Bool -> Bool -> Bool
&& ByteString -> Int -> Char
unsafeIndex ByteString
fs Int
1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/'
     then ByteString
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b) -> b
forall b.
ByteString
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b) -> b
pauthority (Int -> ByteString -> ByteString
drop Int
2 ByteString
fs) Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b
cont
     else ByteString -> ([Char] -> [Char] -> [Char] -> b) -> b
forall b. ByteString -> ([Char] -> [Char] -> [Char] -> b) -> b
puriref ByteString
fs (([Char] -> [Char] -> [Char] -> b) -> b)
-> ([Char] -> [Char] -> [Char] -> b) -> b
forall a b. (a -> b) -> a -> b
$ Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b
cont Maybe URIAuth
forall a. Maybe a
Nothing
pauthority :: ByteString
              -> (Maybe URIAuth -> String -> String -> String -> b)
              -> b
pauthority :: ByteString
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b) -> b
pauthority ByteString
fs Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b
cont =
  let (ByteString
auth,ByteString
rest) = Char -> ByteString -> (ByteString, ByteString)
breakChar Char
'/' ByteString
fs
  in ByteString -> ([Char] -> [Char] -> [Char] -> b) -> b
forall b. ByteString -> ([Char] -> [Char] -> [Char] -> b) -> b
puriref ByteString
rest (([Char] -> [Char] -> [Char] -> b) -> b)
-> ([Char] -> [Char] -> [Char] -> b) -> b
forall a b. (a -> b) -> a -> b
$! Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b
cont (URIAuth -> Maybe URIAuth
forall a. a -> Maybe a
Just (URIAuth -> Maybe URIAuth) -> URIAuth -> Maybe URIAuth
forall a b. (a -> b) -> a -> b
$! ByteString -> URIAuth
pauthinner ByteString
auth)
pauthinner :: ByteString -> URIAuth
pauthinner :: ByteString -> URIAuth
pauthinner ByteString
fs =
  case Char -> ByteString -> (ByteString, ByteString)
breakChar Char
'@' ByteString
fs of
    (ByteString
a,ByteString
b) -> ByteString -> ([Char] -> [Char] -> URIAuth) -> URIAuth
forall t. ByteString -> ([Char] -> [Char] -> t) -> t
pauthport ByteString
b  (([Char] -> [Char] -> URIAuth) -> URIAuth)
-> ([Char] -> [Char] -> URIAuth) -> URIAuth
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> URIAuth
URIAuth (ByteString -> [Char]
unpack ByteString
a)
pauthport :: ByteString -> (String -> String -> t) -> t
pauthport :: ByteString -> ([Char] -> [Char] -> t) -> t
pauthport ByteString
fs [Char] -> [Char] -> t
cont =
  let spl :: Int -> (ByteString, ByteString)
spl Int
idx = Int -> ByteString -> (ByteString, ByteString)
splitAt (Int
idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) ByteString
fs
  in case ByteString -> Char
unsafeHead ByteString
fs of
      Char
_ | ByteString -> Bool
null ByteString
fs -> [Char] -> [Char] -> t
cont [Char]
"" [Char]
""
      Char
'['         -> case (Int -> (ByteString, ByteString))
-> Maybe Int -> Maybe (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> (ByteString, ByteString)
spl (Char -> ByteString -> Maybe Int
elemIndexEnd Char
']' ByteString
fs) of
                       Just (ByteString
a,ByteString
b) | ByteString -> Bool
null ByteString
b              -> [Char] -> [Char] -> t
cont (ByteString -> [Char]
unpack ByteString
a) [Char]
""
                                  | ByteString -> Char
unsafeHead ByteString
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':' -> [Char] -> [Char] -> t
cont (ByteString -> [Char]
unpack ByteString
a) (ByteString -> [Char]
unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
unsafeTail ByteString
b)
                       Maybe (ByteString, ByteString)
x                                -> [Char] -> t
forall a. HasCallStack => [Char] -> a
error ([Char]
"Parsing uri failed (pauthport):"[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++Maybe (ByteString, ByteString) -> [Char]
forall a. Show a => a -> [Char]
show Maybe (ByteString, ByteString)
x)
      Char
_           -> case Char -> ByteString -> (ByteString, ByteString)
breakCharEnd Char
':' ByteString
fs of
                       (ByteString
a,ByteString
b) -> [Char] -> [Char] -> t
cont (ByteString -> [Char]
unpack ByteString
a) (ByteString -> [Char]
unpack ByteString
b)
puriref :: ByteString -> (String -> String -> String -> b) -> b
puriref :: ByteString -> ([Char] -> [Char] -> [Char] -> b) -> b
puriref ByteString
fs [Char] -> [Char] -> [Char] -> b
cont =
  let (ByteString
u,ByteString
r) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
break (\Char
c -> Char
'#' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
|| Char
'?' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) ByteString
fs
  in case ByteString -> Char
unsafeHead ByteString
r of
      Char
_ | ByteString -> Bool
null ByteString
r -> [Char] -> [Char] -> [Char] -> b
cont (ByteString -> [Char]
unpack ByteString
u) [Char]
"" [Char]
""
      Char
'?'        -> ByteString -> ([Char] -> [Char] -> b) -> b
forall t. ByteString -> ([Char] -> [Char] -> t) -> t
pquery    (ByteString -> ByteString
unsafeTail ByteString
r) (([Char] -> [Char] -> b) -> b) -> ([Char] -> [Char] -> b) -> b
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> b
cont (ByteString -> [Char]
unpack ByteString
u)
      Char
'#'        -> ByteString -> ([Char] -> b) -> b
forall b. ByteString -> ([Char] -> b) -> b
pfragment (ByteString -> ByteString
unsafeTail ByteString
r) (([Char] -> b) -> b) -> ([Char] -> b) -> b
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> b
cont (ByteString -> [Char]
unpack ByteString
u) [Char]
""
      Char
_          -> [Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"unexpected match"
pquery :: ByteString -> (String -> String -> t) -> t
pquery :: ByteString -> ([Char] -> [Char] -> t) -> t
pquery ByteString
fs [Char] -> [Char] -> t
cont =
  case Char -> ByteString -> (ByteString, ByteString)
breakChar Char
'#' ByteString
fs of
    (ByteString
a,ByteString
b) -> [Char] -> [Char] -> t
cont (Char
'?'Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:ByteString -> [Char]
unpack ByteString
a) (ByteString -> [Char]
unpack ByteString
b)
pfragment :: ByteString -> (String -> b) -> b
pfragment :: ByteString -> ([Char] -> b) -> b
pfragment ByteString
fs [Char] -> b
cont =
  [Char] -> b
cont ([Char] -> b) -> [Char] -> b
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack ByteString
fs



unsafeTail :: ByteString -> ByteString
unsafeTail :: ByteString -> ByteString
unsafeTail = ByteString -> ByteString
BB.unsafeTail
unsafeHead :: ByteString -> Char
unsafeHead :: ByteString -> Char
unsafeHead = Word8 -> Char
BB.w2c (Word8 -> Char) -> (ByteString -> Word8) -> ByteString -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Word8
BB.unsafeHead
unsafeIndex :: ByteString -> Int -> Char
unsafeIndex :: ByteString -> Int -> Char
unsafeIndex ByteString
s = Word8 -> Char
BB.w2c (Word8 -> Char) -> (Int -> Word8) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int -> Word8
BB.unsafeIndex ByteString
s

-- | Semantically equivalent to break on strings
{-# INLINE breakChar #-}
breakChar :: Char -> ByteString -> (ByteString, ByteString)
breakChar :: Char -> ByteString -> (ByteString, ByteString)
breakChar Char
ch = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BB.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
(==) Word8
x) where x :: Word8
x = Char -> Word8
BB.c2w Char
ch

-- | 'breakCharEnd' behaves like breakChar, but from the end of the
-- ByteString.
--
-- > breakCharEnd ('b') (pack "aabbcc") == ("aab","cc")
--
-- and the following are equivalent:
--
-- > breakCharEnd 'c' "abcdef"
-- > let (x,y) = break (=='c') (reverse "abcdef")
-- > in (reverse (drop 1 y), reverse x)
--
{-# INLINE breakCharEnd #-}
breakCharEnd :: Char -> ByteString -> (ByteString, ByteString)
breakCharEnd :: Char -> ByteString -> (ByteString, ByteString)
breakCharEnd Char
c ByteString
p = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BB.breakEnd (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
(==) Word8
x) ByteString
p where x :: Word8
x = Char -> Word8
BB.c2w Char
c