81 lines
2.5 KiB
Haskell
81 lines
2.5 KiB
Haskell
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
module Blog.URL (
|
|
URLs(..)
|
|
, (./)
|
|
, (//)
|
|
, build
|
|
, checkURL
|
|
, 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.Text (Text, pack)
|
|
import Network.URL (URL(..), URLType(..), exportURL, importURL)
|
|
import System.Exit (die)
|
|
import System.IO (hPutStrLn, stderr)
|
|
import System.FilePath ((</>))
|
|
import Text.Printf (printf)
|
|
|
|
data URLs = URLs {
|
|
cards :: Maybe URL
|
|
, comments :: Maybe URL
|
|
, rss :: Maybe URL
|
|
}
|
|
|
|
instance ToJSON URLs where
|
|
toJSON (URLs {comments}) = object [
|
|
("comments", toJSON (exportURL <$> comments))
|
|
]
|
|
toEncoding (URLs {comments}) = pairs (
|
|
"comments" .= (exportURL <$> comments)
|
|
)
|
|
|
|
checkURL :: MonadIO m => String -> m URL
|
|
checkURL url =
|
|
maybe (liftIO . die $ printf "Invalid URL %s" url) pure $ importURL 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 -> String -> IO (Maybe URL)
|
|
getURL Nothing (Just url) _ = Just <$> checkURL url
|
|
getURL (Just True) Nothing reason = die reason
|
|
getURL (Just True) (Just url) reason = Just <$> checkURL url
|
|
getURL _ _ _ = pure Nothing
|
|
|
|
build :: Arguments -> IO URLs
|
|
build arguments = do
|
|
cards <- getURL (Just argOGCards) siteURL "Open Graph cards"
|
|
rss <- getURL (Just argRSS) siteURL "RSS feeds"
|
|
comments <- getURL Nothing commentsURL "Comments"
|
|
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
|
|
errorMsg :: String -> String
|
|
errorMsg = 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 = []}
|
|
|
|
toText :: URL -> Text
|
|
toText = pack . exportURL
|
|
|
|
(./) :: URL -> FilePath -> Text
|
|
(./) url subPath = toText $ url {url_path = url_path url </> subPath}
|
|
|
|
(//) :: URL -> URL -> Text
|
|
(//) _ url@(URL {url_type = Absolute _}) = pack $ exportURL url
|
|
(//) url (URL {url_type = HostRelative, url_path}) = url ./ ('/':url_path)
|
|
(//) url (URL {url_path}) = url ./ url_path
|