SURI.hs

{-# OPTIONS -fglasgow-exts  #-}
module HAppS.Server.SURI where
import Data.Maybe
import Data.Generics
import HAppS.Util.Common(mapFst)
import qualified Network.URI as URI

path, query, scheme :: SURI -> String
path  = URI.uriPath . suri
query  = URI.uriQuery . suri
scheme  = URI.uriScheme . suri

u_scheme, u_path :: (String -> String) -> SURI -> SURI
u_scheme f (SURI u) = SURI (u {URI.uriScheme=f $ URI.uriScheme u})
u_path f (SURI u) = SURI $ u {URI.uriPath=f $ URI.uriPath u}
a_scheme, a_path :: String -> SURI -> SURI
a_scheme a (SURI u) = SURI $ u {URI.uriScheme=a}
a_path a (SURI u) = SURI $ u {URI.uriPath=a}

escape, unEscape :: String -> String
unEscape = URI.unEscapeString . map (\x->if x=='+' then ' ' else x)
escape = URI.escapeURIString URI.isAllowedInURI

isAbs :: SURI -> Bool
isAbs = not . null . URI.uriScheme . suri
--isAbs = maybe True ( mbParsed

newtype SURI = SURI {suri::URI.URI} deriving (Eq,Data,Typeable)
instance Show SURI where
    showsPrec d (SURI uri) = showsPrec d $ show uri
instance Read SURI where
    readsPrec d = mapFst fromJust .  filter (isJust . fst) . mapFst parse . readsPrec d 

instance Ord SURI where
    compare a b = show a `compare` show b

--parse  = fmap SURI . URI.parseURIReference ::String->Maybe SURI

-- | Render should be used for prettyprinting URIs.
render :: (ToSURI a) => a -> String
render x = (show . suri . toSURI) x
parse :: String -> Maybe SURI
parse =  fmap SURI . URI.parseURIReference 

--mbParse::String->Maybe SURI


--let x = readsPrec 5 s in if null x then Nothing 
--                    else Just $ fst $ head x

class ToSURI x where toSURI::x->SURI
--instance ToSURI (Maybe x) where toSURI =toSURI.fromJust
instance ToSURI SURI where toSURI=id
instance ToSURI URI.URI where toSURI=SURI
instance ToSURI String where 
    toSURI = maybe (SURI $ URI.URI "" Nothing "" "" "") id . parse

--class ToSURI x where toSURI::x->SURI
--instance ToSURI SURI where toSURI=id
--instance ToURI String where toURI=URI
--instance ToURI String 
--    where toURI s = maybe (URI "" Nothing "" s "") id (parseURIReference s)

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