Data commit

Task/URL-parser/Haskell/url-parser.hs

@@ -0,0 +1,75 @@
+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 ""