url.hs

url.hs

module Url where

import Data.Text (Text)
import qualified Data.Text as T
import Data.Word (Word)

newtype Scheme = Scheme Text deriving (Eq, Ord, Show)
newtype Host = Host Text deriving (Eq, Ord, Show)
newtype Path = Path [Text] deriving (Eq, Ord, Show)
newtype Query = Query [(Text, Text)] deriving (Eq, Ord, Show)

data Authority = Authority Scheme Host (Maybe Word)
  deriving (Eq, Ord)
instance Show Authority where
  show = T.unpack . authorityToText

data Url = Url Authority Path Query
  deriving (Eq, Ord)
instance Show Url where
  show = T.unpack . urlToText

authorityToText :: Authority -> Text
authorityToText (Authority (Scheme scheme) (Host host) port') =
  scheme <> "://" <> host <> maybe "" ((":" <>) . T.pack . show) port'

urlToText :: Url -> Text
urlToText (Url authority (Path path) (Query query)) =
  authorityToText authority <> "/" <> T.intercalate "/" path <> queryToText query
  where
    queryToText q = case q of
      [] -> ""
      xs -> "?" <> T.intercalate "&" [k <> "=" <> v | (k, v) <- xs]

host :: Text -> Host
host x = Host $ T.dropAround (`elem` [' ', '/']) x

https :: Scheme
https = Scheme "https"

http :: Scheme
http = Scheme "http"

scheme :: Text -> Scheme
scheme = T.dropEnd (== ':') . T.strip

(<://>) :: Scheme -> Host -> Authority
scheme <://> host = Authority scheme host Nothing

(<:>) :: Authority -> Word -> Authority
(Authority s h _) <:> port = Authority s h (Just port)

(/>) :: Path -> Text -> Path
(Path xs) </> p = Path (xs <> [p])

(</>) :: Authority -> Path -> Url
a </> p = Url a p (Query [])

-- https <://> host "https://gitlab.com" </> path "api" /> path "v4"