114 lines
3.8 KiB
Haskell
114 lines
3.8 KiB
Haskell
{-# 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
|