{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeSynonymInstances #-}
-- | A wrapper and type class so that functions like 'seeOther' can take a URI which is represented by a 'String', 'URI.URI', or other instance of 'ToSURI'.
module Happstack.Server.SURI
    ( path
    , query
    , scheme
    , u_scheme
    , u_path
    , a_scheme
    , a_path
    , percentDecode
    , unEscape
    , unEscapeQS
    , isAbs
    , SURI(..)
    , render
    , parse
    , ToSURI(..)
    , FromPath(..)
    )
    where

import Control.Arrow (first)
import Data.Char     (chr, digitToInt, isHexDigit)
import Data.Maybe    (fromJust, isJust)
import Data.Generics (Data, Typeable)
import qualified Data.Text      as Text
import qualified Data.Text.Lazy as LazyText
import qualified Network.URI    as URI

-- | Retrieves the path component from the URI
path :: SURI -> String
path :: SURI -> String
path  = URI -> String
URI.uriPath forall b c a. (b -> c) -> (a -> b) -> a -> c
. SURI -> URI
suri

-- | Retrieves the query component from the URI
query :: SURI -> String
query :: SURI -> String
query  = URI -> String
URI.uriQuery forall b c a. (b -> c) -> (a -> b) -> a -> c
. SURI -> URI
suri

-- | Retrieves the scheme component from the URI
scheme :: SURI -> String
scheme :: SURI -> String
scheme  = URI -> String
URI.uriScheme forall b c a. (b -> c) -> (a -> b) -> a -> c
. SURI -> URI
suri

-- | Modifies the scheme component of the URI using the provided function
u_scheme :: (String -> String) -> SURI -> SURI
u_scheme :: (String -> String) -> SURI -> SURI
u_scheme String -> String
f (SURI URI
u) = URI -> SURI
SURI (URI
u {uriScheme :: String
URI.uriScheme=String -> String
f forall a b. (a -> b) -> a -> b
$ URI -> String
URI.uriScheme URI
u})

-- | Modifies the path component of the URI using the provided function
u_path :: (String -> String) -> SURI -> SURI
u_path :: (String -> String) -> SURI -> SURI
u_path String -> String
f (SURI URI
u) = URI -> SURI
SURI forall a b. (a -> b) -> a -> b
$ URI
u {uriPath :: String
URI.uriPath=String -> String
f forall a b. (a -> b) -> a -> b
$ URI -> String
URI.uriPath URI
u}

-- | Sets the scheme component of the URI
a_scheme :: String -> SURI -> SURI
a_scheme :: String -> SURI -> SURI
a_scheme String
a (SURI URI
u) = URI -> SURI
SURI forall a b. (a -> b) -> a -> b
$ URI
u {uriScheme :: String
URI.uriScheme=String
a}

-- | Sets the path component of the URI
a_path :: String -> SURI -> SURI
a_path :: String -> SURI -> SURI
a_path String
a (SURI URI
u) = URI -> SURI
SURI forall a b. (a -> b) -> a -> b
$ URI
u {uriPath :: String
URI.uriPath=String
a}

-- | percent decode a String
--
-- e.g. @\"hello%2Fworld\"@ -> @\"hello/world\"@
percentDecode :: String -> String
percentDecode :: String -> String
percentDecode [] = String
""
percentDecode (Char
'%':Char
x1:Char
x2:String
s) | Char -> Bool
isHexDigit Char
x1 Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
x2 =
    Int -> Char
chr (Char -> Int
digitToInt Char
x1 forall a. Num a => a -> a -> a
* Int
16 forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
x2) forall a. a -> [a] -> [a]
: String -> String
percentDecode String
s
percentDecode (Char
c:String
s) = Char
c forall a. a -> [a] -> [a]
: String -> String
percentDecode String
s

unEscape, unEscapeQS :: String -> String
unEscapeQS :: String -> String
unEscapeQS = String -> String
percentDecode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Char
x->if Char
xforall a. Eq a => a -> a -> Bool
==Char
'+' then Char
' ' else Char
x)
unEscape :: String -> String
unEscape   = String -> String
percentDecode
-- escape     = URI.escapeURIString URI.isAllowedInURI

-- | Returns true if the URI is absolute
isAbs :: SURI -> Bool
isAbs :: SURI -> Bool
isAbs = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
URI.uriScheme forall b c a. (b -> c) -> (a -> b) -> a -> c
. SURI -> URI
suri

newtype SURI = SURI {SURI -> URI
suri::URI.URI} deriving (SURI -> SURI -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SURI -> SURI -> Bool
$c/= :: SURI -> SURI -> Bool
== :: SURI -> SURI -> Bool
$c== :: SURI -> SURI -> Bool
Eq,Typeable SURI
SURI -> DataType
SURI -> Constr
(forall b. Data b => b -> b) -> SURI -> SURI
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> SURI -> u
forall u. (forall d. Data d => d -> u) -> SURI -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> SURI -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> SURI -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SURI -> m SURI
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SURI -> m SURI
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SURI
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SURI -> c SURI
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SURI)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SURI)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SURI -> m SURI
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SURI -> m SURI
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SURI -> m SURI
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SURI -> m SURI
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SURI -> m SURI
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SURI -> m SURI
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SURI -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SURI -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> SURI -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SURI -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> SURI -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> SURI -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> SURI -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> SURI -> r
gmapT :: (forall b. Data b => b -> b) -> SURI -> SURI
$cgmapT :: (forall b. Data b => b -> b) -> SURI -> SURI
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SURI)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SURI)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SURI)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SURI)
dataTypeOf :: SURI -> DataType
$cdataTypeOf :: SURI -> DataType
toConstr :: SURI -> Constr
$ctoConstr :: SURI -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SURI
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SURI
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SURI -> c SURI
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SURI -> c SURI
Data,Typeable)
instance Show SURI where
    showsPrec :: Int -> SURI -> String -> String
showsPrec Int
d (SURI URI
uri) = forall a. Show a => Int -> a -> String -> String
showsPrec Int
d forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show URI
uri
instance Read SURI where
    readsPrec :: Int -> ReadS SURI
readsPrec Int
d = forall a b x. (a -> b) -> [(a, x)] -> [(b, x)]
mapFst forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b x. (a -> b) -> [(a, x)] -> [(b, x)]
mapFst String -> Maybe SURI
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => Int -> ReadS a
readsPrec Int
d
      where
        mapFst :: (a -> b) -> [(a,x)] -> [(b,x)]
        mapFst :: forall a b x. (a -> b) -> [(a, x)] -> [(b, x)]
mapFst = forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first

instance Ord SURI where
    compare :: SURI -> SURI -> Ordering
compare SURI
a SURI
b = forall a. Show a => a -> String
show SURI
a forall a. Ord a => a -> a -> Ordering
`compare` forall a. Show a => a -> String
show SURI
b

-- | Render should be used for prettyprinting URIs.
render :: (ToSURI a) => a -> String
render :: forall a. ToSURI a => a -> String
render = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. SURI -> URI
suri forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. ToSURI x => x -> SURI
toSURI

-- | Parses a URI from a String.  Returns Nothing on failure.
parse :: String -> Maybe SURI
parse :: String -> Maybe SURI
parse =  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URI -> SURI
SURI forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe URI
URI.parseURIReference

-- | Convenience class for converting data types to URIs
class ToSURI x where toSURI::x->SURI

instance ToSURI SURI where toSURI :: SURI -> SURI
toSURI=forall a. a -> a
id
instance ToSURI URI.URI where toSURI :: URI -> SURI
toSURI=URI -> SURI
SURI
instance ToSURI String where
    toSURI :: String -> SURI
toSURI = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (URI -> SURI
SURI forall a b. (a -> b) -> a -> b
$ String -> Maybe URIAuth -> String -> String -> String -> URI
URI.URI String
"" forall a. Maybe a
Nothing String
"" String
"" String
"") forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe SURI
parse
instance ToSURI Text.Text where toSURI :: Text -> SURI
toSURI = forall x. ToSURI x => x -> SURI
toSURI forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
instance ToSURI LazyText.Text where toSURI :: Text -> SURI
toSURI = forall x. ToSURI x => x -> SURI
toSURI forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
LazyText.unpack

--handling obtaining things from URI paths
class FromPath x where fromPath::String->x