-- | A URI parsing library
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# OPTIONS_HADDOCK prune               #-}
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)


-- | Protocol is a basic protocol string, such as "http" or "ftp"
newtype Protocol    = Protocol { _protocol :: Text } deriving (Eq, Show, IsString)
-- | FQDN is the complete hostname of the server
newtype FQDN        = FQDN { _fqdn :: Text } deriving (Eq, Show, IsString)
-- | Optional, but Port allows one to specify a non-default port for a URI
newtype Port        = Port { _port :: Int } deriving (Eq, Show, Num)
-- | The path section of the URI, divided into one element per subdirectory
newtype PathParts   = PathParts { _pathParts :: [Text] } deriving (Eq, Show, Monoid)

-- | A straightforward URI data type
--
-- TODO: need to support usernames and passwords as part of the URI, such as postgres://username:password@localhost:5432/my_database
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 treats the path portion of the URI as a single string. This is more common and natural most of the time.
uriPath :: Lens' URI Text
uriPath f uri@URI{..} =
    fmap (\n' -> uri { _uriPathParts = pathParts n' })
         (f $ "/" <> intercalate "/" (_pathParts _uriPathParts))


-- | Parse a URI from Text, returning either an error or a complete URI
--
-- TODO: Rebuild these functions for easy ByteString, Text, String parsing and rendering
parseURI :: Text -> Either String URI
parseURI = parseOnly uriParser

-- | Parse a URI from a String, returning either an error or a complete URI
parseURI' :: String -> Either String URI
parseURI' = parseURI . pack


{- | Render a URI to a ByteString
 - I chose bytestrings because they are so frequently required in HTTP libraries.
 -}
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


-- renderURI' :: URI -> String
-- renderURI' = unpack . renderURI


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