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 fs :: ByteString
fs =
  case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
break (\c :: Char
c -> ':' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
|| '/' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
|| '?' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
|| '#' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) ByteString
fs of
  (initial :: ByteString
initial,rest :: ByteString
rest) ->
      let ui :: [Char]
ui = ByteString -> [Char]
unpack ByteString
initial
      in case ByteString -> Maybe (Char, ByteString)
uncons ByteString
rest of
         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 (c :: Char
c, rrest :: ByteString
rrest) ->
             case Char
c of
             ':' -> 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)
             '/' -> 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 "" Maybe URIAuth
forall a. Maybe a
Nothing
             '?' -> 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 "" Maybe URIAuth
forall a. Maybe a
Nothing [Char]
ui
             '#' -> 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 "" Maybe URIAuth
forall a. Maybe a
Nothing [Char]
ui ""
             _   -> [Char] -> URI
forall a. HasCallStack => [Char] -> a
error "parseURIRef: Can't happen"

pabsuri :: ByteString
           -> (Maybe URIAuth -> String -> String -> String -> b)
           -> b
pabsuri :: ByteString
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b) -> b
pabsuri fs :: ByteString
fs cont :: Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b
cont =
  if ByteString -> Int
length ByteString
fs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 2 Bool -> Bool -> Bool
&& ByteString -> Char
unsafeHead ByteString
fs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/' Bool -> Bool -> Bool
&& ByteString -> Int -> Char
unsafeIndex ByteString
fs 1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '/'
     then ByteString
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b) -> b
forall b.
ByteString
-> (Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b) -> b
pauthority (Int -> ByteString -> ByteString
drop 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 fs :: ByteString
fs cont :: Maybe URIAuth -> [Char] -> [Char] -> [Char] -> b
cont =
  let (auth :: ByteString
auth,rest :: ByteString
rest) = Char -> ByteString -> (ByteString, ByteString)
breakChar '/' 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 fs :: ByteString
fs =
  case Char -> ByteString -> (ByteString, ByteString)
breakChar '@' ByteString
fs of
    (a :: ByteString
a,b :: 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 fs :: ByteString
fs cont :: [Char] -> [Char] -> t
cont =
  let spl :: Int -> (ByteString, ByteString)
spl idx :: Int
idx = Int -> ByteString -> (ByteString, ByteString)
splitAt (Int
idxInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) ByteString
fs
  in case ByteString -> Char
unsafeHead ByteString
fs of
      _ | ByteString -> Bool
null ByteString
fs -> [Char] -> [Char] -> t
cont "" ""
      '['         -> 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 ']' ByteString
fs) of
                       Just (a :: ByteString
a,b :: ByteString
b) | ByteString -> Bool
null ByteString
b              -> [Char] -> [Char] -> t
cont (ByteString -> [Char]
unpack ByteString
a) ""
                                  | ByteString -> Char
unsafeHead ByteString
b Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':' -> [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)
                       x :: Maybe (ByteString, ByteString)
x                                -> [Char] -> t
forall a. HasCallStack => [Char] -> a
error ("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)
      _           -> case Char -> ByteString -> (ByteString, ByteString)
breakCharEnd ':' ByteString
fs of
                       (a :: ByteString
a,b :: 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 fs :: ByteString
fs cont :: [Char] -> [Char] -> [Char] -> b
cont =
  let (u :: ByteString
u,r :: ByteString
r) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
break (\c :: Char
c -> '#' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
|| '?' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) ByteString
fs
  in case ByteString -> Char
unsafeHead ByteString
r of
      _ | ByteString -> Bool
null ByteString
r -> [Char] -> [Char] -> [Char] -> b
cont (ByteString -> [Char]
unpack ByteString
u) "" ""
      '?'        -> 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)
      '#'        -> 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] -> b
forall a. HasCallStack => [Char] -> a
error "unexpected match"
pquery :: ByteString -> (String -> String -> t) -> t
pquery :: ByteString -> ([Char] -> [Char] -> t) -> t
pquery fs :: ByteString
fs cont :: [Char] -> [Char] -> t
cont =
  case Char -> ByteString -> (ByteString, ByteString)
breakChar '#' ByteString
fs of
    (a :: ByteString
a,b :: ByteString
b) -> [Char] -> [Char] -> t
cont ('?'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 fs :: ByteString
fs cont :: [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 s :: 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 ch :: 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 c :: Char
c p :: 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