module LuminescentDreams.Data.URI (
renderQuery
, Protocol(..), FQDN(..), Port(..), PathParts(..), URI
, uriProtocol, uriFqdn, uriPort, uriPathParts, uriQueryParams, uriPath
, parseURI, parseURI', renderURI
) where
import Prelude
import Control.Lens
import Control.Monad (void)
import Data.Attoparsec.Text
import Data.ByteString (ByteString)
import Data.Monoid ((<>))
import Data.String (IsString)
import Data.Default
import Data.Text (Text, intercalate, splitOn, pack)
import Data.Text.Encoding (encodeUtf8)
import Network.HTTP.Types (Query, renderQuery)
newtype Protocol = Protocol { _protocol :: Text } deriving (Eq, Show, IsString)
newtype FQDN = FQDN { _fqdn :: Text } deriving (Eq, Show, IsString)
newtype Port = Port { _port :: Int } deriving (Eq, Show, Num)
newtype PathParts = PathParts { _pathParts :: [Text] } deriving (Eq, Show, Monoid)
data URI = URI { _uriProtocol :: Protocol
, _uriFqdn :: FQDN
, _uriPort :: Maybe Port
, _uriPathParts :: PathParts
, _uriQueryParams :: Query
} deriving (Eq, Show)
instance Default URI where
def = URI (Protocol "") (FQDN "") Nothing (PathParts []) []
pathParts :: Text -> PathParts
pathParts = PathParts . filter (/= "") . splitOn "/"
uriPath :: Lens' URI Text
uriPath f uri@URI{..} =
fmap (\n' -> uri { _uriPathParts = pathParts n' })
(f $ "/" <> intercalate "/" (_pathParts _uriPathParts))
parseURI :: Text -> Either String URI
parseURI = parseOnly uriParser
parseURI' :: String -> Either String URI
parseURI' = parseURI . pack
renderURI :: URI -> ByteString
renderURI uri@URI{..}
| uri == def = ""
| otherwise = encodeUtf8 (_protocol _uriProtocol)
<> "://"
<> encodeUtf8 (_fqdn _uriFqdn)
<> maybe "" (encodeUtf8 . (<>) ":" . pack . show . _port) _uriPort
<> "/"
<> encodeUtf8 (intercalate "/" (_pathParts _uriPathParts))
<> renderQuery True _uriQueryParams
uriParser :: Parser URI
uriParser = do
protocol <- many1 letter
void $ string "://"
fqdn <- many1 (choice [letter, char '.', digit, char '_', char '-'])
next <- choice [char ':', char '/']
port <- case next of
':' -> do
port <- (Just . read) `fmap` many1 digit
void $ char '/'
return port
_ -> return Nothing
path <- many' anyChar
return $ def { _uriProtocol = Protocol $ pack protocol
, _uriFqdn = FQDN $ pack fqdn
, _uriPort = Port `fmap` port
, _uriPathParts = pathParts $ pack path
}
makeLenses ''URI