module Main (main) where import Data.Foldable (for_) import Network.URI ( URI , URIAuth , parseURI , uriAuthority , uriFragment , uriPath , uriPort , uriQuery , uriRegName , uriScheme , uriUserInfo ) uriStrings :: [String] uriStrings = [ "https://bob:pass@example.com/place" , "foo://example.com:8042/over/there?name=ferret#nose" , "urn:example:animal:ferret:nose" , "jdbc:mysql://test_user:ouupppssss@localhost:3306/sakila?profileSQL=true" , "ftp://ftp.is.co.za/rfc/rfc1808.txt" , "http://www.ietf.org/rfc/rfc2396.txt#header1" , "ldap://[2001:db8::7]/c=GB?objectClass?one" , "mailto:John.Doe@example.com" , "news:comp.infosystems.www.servers.unix" , "tel:+1-816-555-1212" , "telnet://192.0.2.16:80/" , "urn:oasis:names:specification:docbook:dtd:xml:4.1.2" ] trimmedUriScheme :: URI -> String trimmedUriScheme = init . uriScheme trimmedUriUserInfo :: URIAuth -> Maybe String trimmedUriUserInfo uriAuth = case uriUserInfo uriAuth of [] -> Nothing userInfo -> if last userInfo == '@' then Just (init userInfo) else Nothing trimmedUriPath :: URI -> String trimmedUriPath uri = case uriPath uri of '/' : t -> t; p -> p trimmedUriQuery :: URI -> Maybe String trimmedUriQuery uri = case uriQuery uri of '?' : t -> Just t; _ -> Nothing trimmedUriFragment :: URI -> Maybe String trimmedUriFragment uri = case uriFragment uri of '#' : t -> Just t; _ -> Nothing main :: IO () main = do for_ uriStrings $ \uriString -> do case parseURI uriString of Nothing -> putStrLn $ "Could not parse" ++ uriString Just uri -> do putStrLn uriString putStrLn $ " scheme = " ++ trimmedUriScheme uri case uriAuthority uri of Nothing -> return () Just uriAuth -> do case trimmedUriUserInfo uriAuth of Nothing -> return () Just userInfo -> putStrLn $ " user-info = " ++ userInfo putStrLn $ " domain = " ++ uriRegName uriAuth putStrLn $ " port = " ++ uriPort uriAuth putStrLn $ " path = " ++ trimmedUriPath uri case trimmedUriQuery uri of Nothing -> return () Just query -> putStrLn $ " query = " ++ query case trimmedUriFragment uri of Nothing -> return () Just fragment -> putStrLn $ " fragment = " ++ fragment putStrLn ""