{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Blog.URL (
      AbsoluteURL(..)
    , URLs(..)
    , build
    , checkURL
    , defaultOn
    , localPrefix
    , pathOn
    , pathRelative
    , toText
  ) where

import Arguments (Arguments)
import qualified Arguments as Arguments (Arguments(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Aeson (ToJSON(..), (.=), object, pairs)
import Data.Function (on)
import Data.List (unionBy)
import Data.Text (Text, pack)
import Network.URL (Host, URL(..), URLType(..), exportURL, importURL)
import System.Exit (die)
import System.IO (hPutStrLn, stderr)
import System.FilePath ((</>))
import Text.Printf (printf)

data AbsoluteURL = AbsoluteURL {
      host :: Host
    , urlPath :: FilePath
    , urlParams :: [(String, String)]
  }

toText :: AbsoluteURL -> Text
toText (AbsoluteURL {host, urlPath, urlParams}) =
  pack . exportURL $ URL (Absolute host) urlPath urlParams

data URLs = URLs {
      cards :: Maybe AbsoluteURL
    , comments :: Maybe AbsoluteURL
    , rss :: Maybe AbsoluteURL
  }

instance ToJSON URLs where
  toJSON (URLs {comments}) = object [
      ("comments", toJSON (toText <$> comments))
    ]
  toEncoding (URLs {comments}) = pairs (
      "comments" .= (toText <$> comments)
    )

checkURL :: MonadIO m => String -> m URL
checkURL url =
  maybe (liftIO . die $ printf "Invalid URL %s" url) pure $ importURL url

checkAbsolute :: MonadIO m => URL -> m AbsoluteURL
checkAbsolute (URL {url_type = Absolute host, url_path, url_params}) =
  pure $ AbsoluteURL host url_path url_params
checkAbsolute url =
  liftIO . die . printf "%s is not an absolute URL" $ exportURL url

checksUsed :: Bool -> Maybe a -> IO ()
checksUsed False (Just _) =
  hPutStrLn stderr "Site url is set but not used, did you forget --open-graph-cards or --rss ?"
checksUsed _ _ = return ()

getURL :: Maybe Bool -> Maybe String -> IO (Maybe AbsoluteURL) -> IO (Maybe AbsoluteURL)
getURL Nothing (Just url) _ = Just <$> (checkAbsolute =<< checkURL url)
getURL (Just True) Nothing failure = failure
getURL (Just True) (Just url) _ = Just <$> (checkAbsolute =<< checkURL url)
getURL _ _ _ = pure Nothing

build :: Arguments -> IO URLs
build arguments = do
  cards <- getURL (Just argOGCards) siteURL (failBecauseOf "Open Graph cards")
  rss <- getURL (Just argRSS) siteURL (failBecauseOf "RSS feeds")
  comments <- getURL Nothing commentsURL (pure Nothing)
  checksUsed (argOGCards || argRSS) siteURL
  return $ URLs {cards, comments, rss}
  where
    commentsURL = Arguments.commentsURL arguments
    siteURL = Arguments.siteURL arguments
    argOGCards = Arguments.openGraphCards arguments
    argRSS = Arguments.rss arguments
    failBecauseOf :: String -> IO a
    failBecauseOf =
      die . printf "Enabling %s requires setting the site url with --site-url"

pathRelative :: String -> URL
pathRelative url_path = URL {url_type = PathRelative, url_path, url_params = []}

addParams :: AbsoluteURL -> [(String, String)] -> AbsoluteURL
addParams url newParams = url {
    urlParams = unionBy ((==) `on` fst) newParams (urlParams url)
  }

pathOn :: AbsoluteURL -> FilePath -> Text
pathOn url = toText . setPath
  where setPath ('/':urlPath) = url {urlPath}
        setPath subPath = url {urlPath = urlPath url </> subPath}

defaultOn :: AbsoluteURL -> URL -> Text
defaultOn _ (URL {url_type = Absolute host, url_path, url_params}) =
  toText $ AbsoluteURL host url_path url_params
defaultOn url (URL {url_type = HostRelative, url_path, url_params}) =
  toText $ addParams (url {urlPath = url_path}) url_params
defaultOn url (URL {url_path, url_params}) =
  pathOn (addParams url url_params) url_path

localPrefix :: FilePath -> URL -> Text
localPrefix base url = pack . prefix (url_type url) $ exportURL url
  where prefix PathRelative = (base </>)
        prefix _ = id