{-# 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 (URI -> String) -> (SURI -> URI) -> SURI -> String
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 (URI -> String) -> (SURI -> URI) -> SURI -> String
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 (URI -> String) -> (SURI -> URI) -> SURI -> String
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 (String -> String) -> String -> String
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 (URI -> SURI) -> URI -> SURI
forall a b. (a -> b) -> a -> b
$ URI
u {uriPath :: String
URI.uriPath=String -> String
f (String -> String) -> String -> String
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 (URI -> SURI) -> URI -> 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 (URI -> SURI) -> URI -> 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
x2) Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
percentDecode String
s
percentDecode (Char
c:String
s) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
percentDecode String
s

unEscape, unEscapeQS :: String -> String
unEscapeQS :: String -> String
unEscapeQS = String -> String
percentDecode (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x->if Char
xChar -> Char -> Bool
forall 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 (Bool -> Bool) -> (SURI -> Bool) -> SURI -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> (SURI -> String) -> SURI -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
URI.uriScheme (URI -> String) -> (SURI -> URI) -> SURI -> String
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
(SURI -> SURI -> Bool) -> (SURI -> SURI -> Bool) -> Eq SURI
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
DataType
Constr
Typeable SURI
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> SURI -> c SURI)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c SURI)
-> (SURI -> Constr)
-> (SURI -> DataType)
-> (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))
-> ((forall b. Data b => b -> b) -> SURI -> SURI)
-> (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 u. (forall d. Data d => d -> u) -> SURI -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> SURI -> u)
-> (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 (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> SURI -> m SURI)
-> Data SURI
SURI -> DataType
SURI -> Constr
(forall b. Data b => b -> b) -> SURI -> SURI
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SURI -> c SURI
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c 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)
$cSURI :: Constr
$tSURI :: DataType
gmapMo :: (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 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 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 :: Int -> (forall d. Data d => d -> u) -> SURI -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SURI -> u
gmapQ :: (forall d. Data d => d -> u) -> SURI -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SURI -> [u]
gmapQr :: (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 :: (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 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 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 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 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
$cp1Data :: Typeable SURI
Data,Typeable)
instance Show SURI where
    showsPrec :: Int -> SURI -> String -> String
showsPrec Int
d (SURI URI
uri) = Int -> String -> String -> String
forall a. Show a => Int -> a -> String -> String
showsPrec Int
d (String -> String -> String) -> String -> String -> String
forall a b. (a -> b) -> a -> b
$ URI -> String
forall a. Show a => a -> String
show URI
uri
instance Read SURI where
    readsPrec :: Int -> ReadS SURI
readsPrec Int
d = (Maybe SURI -> SURI) -> [(Maybe SURI, String)] -> [(SURI, String)]
forall a b x. (a -> b) -> [(a, x)] -> [(b, x)]
mapFst Maybe SURI -> SURI
forall a. HasCallStack => Maybe a -> a
fromJust ([(Maybe SURI, String)] -> [(SURI, String)])
-> (String -> [(Maybe SURI, String)]) -> ReadS SURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  ((Maybe SURI, String) -> Bool)
-> [(Maybe SURI, String)] -> [(Maybe SURI, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe SURI -> Bool
forall a. Maybe a -> Bool
isJust (Maybe SURI -> Bool)
-> ((Maybe SURI, String) -> Maybe SURI)
-> (Maybe SURI, String)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe SURI, String) -> Maybe SURI
forall a b. (a, b) -> a
fst) ([(Maybe SURI, String)] -> [(Maybe SURI, String)])
-> (String -> [(Maybe SURI, String)])
-> String
-> [(Maybe SURI, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe SURI)
-> [(String, String)] -> [(Maybe SURI, String)]
forall a b x. (a -> b) -> [(a, x)] -> [(b, x)]
mapFst String -> Maybe SURI
parse ([(String, String)] -> [(Maybe SURI, String)])
-> (String -> [(String, String)])
-> String
-> [(Maybe SURI, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> [(String, String)]
forall a. Read a => Int -> ReadS a
readsPrec Int
d
      where
        mapFst :: (a -> b) -> [(a,x)] -> [(b,x)]
        mapFst :: (a -> b) -> [(a, x)] -> [(b, x)]
mapFst = ((a, x) -> (b, x)) -> [(a, x)] -> [(b, x)]
forall a b. (a -> b) -> [a] -> [b]
map (((a, x) -> (b, x)) -> [(a, x)] -> [(b, x)])
-> ((a -> b) -> (a, x) -> (b, x))
-> (a -> b)
-> [(a, x)]
-> [(b, x)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> (a, x) -> (b, x)
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 = SURI -> String
forall a. Show a => a -> String
show SURI
a String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` SURI -> String
forall a. Show a => a -> String
show SURI
b

-- | Render should be used for prettyprinting URIs.
render :: (ToSURI a) => a -> String
render :: a -> String
render = URI -> String
forall a. Show a => a -> String
show (URI -> String) -> (a -> URI) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SURI -> URI
suri (SURI -> URI) -> (a -> SURI) -> a -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SURI
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 =  (URI -> SURI) -> Maybe URI -> Maybe SURI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap URI -> SURI
SURI (Maybe URI -> Maybe SURI)
-> (String -> Maybe URI) -> String -> Maybe 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=SURI -> SURI
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 = SURI -> (SURI -> SURI) -> Maybe SURI -> SURI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (URI -> SURI
SURI (URI -> SURI) -> URI -> SURI
forall a b. (a -> b) -> a -> b
$ String -> Maybe URIAuth -> String -> String -> String -> URI
URI.URI String
"" Maybe URIAuth
forall a. Maybe a
Nothing String
"" String
"" String
"") SURI -> SURI
forall a. a -> a
id (Maybe SURI -> SURI) -> (String -> Maybe SURI) -> String -> SURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe SURI
parse
instance ToSURI Text.Text where toSURI :: Text -> SURI
toSURI = String -> SURI
forall x. ToSURI x => x -> SURI
toSURI (String -> SURI) -> (Text -> String) -> Text -> SURI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack
instance ToSURI LazyText.Text where toSURI :: Text -> SURI
toSURI = String -> SURI
forall x. ToSURI x => x -> SURI
toSURI (String -> SURI) -> (Text -> String) -> Text -> SURI
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