Ugly JS desperate fix

hablo.cabal

@@ -51,12 +51,13 @@ library
                      , RSS
   -- other-extensions:
   build-depends:       aeson >= 1.2.0 && < 1.6
-                     , base >= 4.9.1 && < 4.15
+                     , base >= 4.9.1 && < 4.16
                      , bytestring >= 0.10.8 && < 0.12
                      , containers >= 0.5.11 && < 0.7
                      , directory >= 1.3.1 && < 1.4
                      , filepath >= 1.4.2 && < 1.5
-                     , lucid >= 2.8.0 && < 2.10
+                     , blaze-html
+                     , blaze-markup
                      , mtl >= 2.2.2 && < 2.3
                      , optparse-applicative >= 0.14.0 && < 0.17
                      , parsec >= 3.1.13 && < 3.2
@@ -65,6 +66,7 @@ library
                      , time >= 1.8.0 && < 1.12
                      , SJW >= 0.1.2 && < 0.2
                      , unix >= 2.7.2 && < 2.8
+                     , url >= 2.1.3 && < 2.2
   ghc-options:         -Wall
   hs-source-dirs:      src
   default-language:    Haskell2010
@@ -73,9 +75,9 @@ executable hablo
   main-is:             src/Main.hs
   other-modules:       Paths_hablo
   -- other-extensions:
-  build-depends:       base >= 4.9.1 && < 4.15
+  build-depends:       base
                      , hablo
-                     , mtl >= 2.2.2 && < 2.3
+                     , mtl
   ghc-options:         -Wall
   default-language:    Haskell2010
 
@@ -93,11 +95,14 @@ test-suite tests
                      , Mock.Blog.Wording
                      , Mock.Collection
                      , Mock.Markdown
+                     , Mock.URL
                      , Structure
+                     , URLs
                      , Utils
                      , XML.Card
                      , XML.Card.Component
                      , XML.Card.Output
+                     , XML.Favicon
   build-depends:       base
                      , Cabal
                      , containers
@@ -107,6 +112,7 @@ test-suite tests
                      , lucid
                      , mtl
                      , text
+                     , url
   hs-source-dirs:      test
   ghc-options:         -Wall
   default-language:    Haskell2010

src/ArticlesList.hs

@@ -6,6 +6,7 @@ module ArticlesList (
     , description
     , getArticles
     , otherURL
+    , ArticlesList.path
     , rssLinkTexts
   ) where
 
@@ -14,9 +15,7 @@ import Blog (Blog(..), Renderer, Skin(..), template)
 import Collection (Collection(..))
 import Control.Monad.Reader (MonadReader, asks)
 import Data.Text (Text, pack)
-import Files (absoluteLink)
 import Pretty ((.$))
-import System.FilePath.Posix ((</>))
 
 data ArticlesList = ArticlesList {
       full :: Bool
@@ -28,9 +27,8 @@ getArticles (ArticlesList {full, collection = Collection {featured}}) = do
   limit <- take <$> (asks $skin.$previewArticlesCount)
   return $ if full then featured else limit featured
 
-otherURL :: ArticlesList -> String
-otherURL (ArticlesList {full, collection}) = absoluteLink $
-  (if full then id else (</> "all.html")) . maybe "" id $ tag collection
+otherURL :: ArticlesList -> FilePath
+otherURL (ArticlesList {full}) = if full then "." else "all.html"
 
 description :: Renderer m => ArticlesList -> m Text
 description (ArticlesList {full, collection}) =
@@ -46,3 +44,6 @@ rssLinkTexts (ArticlesList {collection}) = do
   return (text, title)
   where
     environment = maybe [] (\v -> [("tag", pack v)]) $ tag collection
+
+path :: ArticlesList -> FilePath
+path = maybe "" id . tag . collection

src/Blog.hs

@@ -6,7 +6,7 @@ module Blog (
     , Path(..)
     , Renderer
     , Skin(..)
-    , URL(..)
+    , URLs(..)
     , Wording
     , build
     , template
@@ -22,7 +22,7 @@ import Blog.Template (Environment, Templates, render)
 import qualified Blog.Template as Template (build)
 import Blog.Skin (Skin(..))
 import qualified Blog.Skin as Skin (build)
-import Blog.URL (URL(..))
+import Blog.URL (URLs(..))
 import qualified Blog.URL as URL (build)
 import Blog.Wording (Wording)
 import qualified Blog.Wording as Wording (build)
@@ -57,7 +57,7 @@ data Blog = Blog {
     , skin :: Skin
     , tags :: Collection (Set String)
     , templates :: Templates
-    , urls :: URL
+    , urls :: URLs
     , wording :: Wording
   }
 

src/Blog/Skin.hs

@@ -1,45 +1,49 @@
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE CPP #-}
 module Blog.Skin (
       Skin(..)
     , build
+    , findImage
   ) where
 
 import Arguments (Arguments)
 import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArticlesCount, previewLinesCount)
+import Blog.URL (checkURL, pathRelative)
 import Control.Monad (filterM)
-import Data.Aeson (ToJSON(..), (.=), pairs)
+import Data.Aeson (ToJSON(..), (.=), object, pairs)
 import Data.Maybe (listToMaybe)
 #if !MIN_VERSION_base(4,11,0)
 import Data.Monoid ((<>))
 #endif
-import Files (absoluteLink)
-import GHC.Generics (Generic)
+import Network.URL (URL)
 import Prelude hiding (head)
 import System.Directory (doesFileExist)
 import System.FilePath ((</>), (<.>))
 
 data Skin = Skin {
       banner :: Maybe String
-    , cardImage :: Maybe FilePath
-    , favicon :: Maybe FilePath
+    , cardImage :: Maybe URL
+    , favicon :: Maybe URL
     , head :: Maybe String
     , previewArticlesCount :: Int
     , previewLinesCount :: Int
-  } deriving Generic
+  }
 
 instance ToJSON Skin where
+  toJSON (Skin {previewArticlesCount, previewLinesCount}) = object [
+        ("previewArticlesCount", toJSON previewArticlesCount)
+      , ("previewLinesCount", toJSON previewLinesCount)
+    ]
   toEncoding (Skin {previewArticlesCount, previewLinesCount}) = pairs (
         "previewArticlesCount" .= previewArticlesCount
       <> "previewLinesCount" .= previewLinesCount
     )
 
-findImage :: String -> Maybe FilePath -> IO (Maybe FilePath)
-findImage _ (Just path) = return . Just $ absoluteLink path
+findImage :: String -> Maybe FilePath -> IO (Maybe URL)
+findImage _ (Just path) = Just <$> checkURL path
 findImage name Nothing =
-  listToMaybe <$> filterM doesFileExist pathsToCheck
+  fmap pathRelative . listToMaybe <$> filterM doesFileExist pathsToCheck
   where
     directories = [".", "image", "images", "pictures", "skin", "static"]
     extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"]

src/Blog/URL.hs

@@ -1,45 +1,113 @@
-{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Blog.URL (
-      URL(..)
+      AbsoluteURL(..)
+    , URLs(..)
     , build
+    , checkURL
+    , defaultOn
+    , localPrefix
+    , pathOn
+    , pathRelative
+    , toText
   ) where
 
 import Arguments (Arguments)
 import qualified Arguments as Arguments (Arguments(..))
-import Data.Aeson (ToJSON(..), (.=), pairs)
-import GHC.Generics (Generic)
+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 URL = URL {
-      cards :: Maybe String
-    , comments :: Maybe String
-    , rss :: Maybe String
-  } deriving Generic
+data AbsoluteURL = AbsoluteURL {
+      host :: Host
+    , urlPath :: FilePath
+    , urlParams :: [(String, String)]
+  }
 
-instance ToJSON URL where
-  toEncoding (URL {comments}) = pairs (
-      "comments" .= comments
+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)
     )
 
-build :: Arguments -> IO URL
+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 <- getSiteURL argOGCards "Open Graph cards"
-  rss <- getSiteURL argRSS "RSS feeds"
+  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 $ URL {cards, comments, rss}
+  return $ URLs {cards, comments, rss}
   where
-    comments = Arguments.commentsURL arguments
+    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"
-    getSiteURL False _ = return Nothing
-    getSiteURL True name = maybe (die $ errorMsg name) (return . Just) siteURL
-    checksUsed False (Just _) =
-      hPutStrLn stderr "Site url is set but not used, did you forget --open-graph-cards or --rss ?"
-    checksUsed _ _ = return ()
+    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

src/DOM.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 module DOM (
-      HasContent(..)
+      PageType(..)
     , htmlDocument
   ) where
 
@@ -10,115 +10,129 @@ import qualified Article (preview)
 import ArticlesList (
     ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
   )
-import Blog (Blog(..), Skin(..), URL(..), template)
+import Blog (Blog(..), Skin(..), URLs(..), template)
+import Blog.URL (localPrefix)
+import qualified Collection (tag)
 import Control.Monad.Reader (ReaderT, asks)
 import Data.Map as Map (Map, toList)
 import Data.Text (Text, pack, empty)
 import DOM.Card (HasCard)
 import qualified DOM.Card as Card (make)
-import Files (absoluteLink)
-import Lucid (
-      HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_, h1_, h2_
-    , head_, header_, href_, li_, link_, id_, meta_, pre_, rel_, script_, src_
-    , title_, toHtml, toHtmlRaw, type_, ul_
-  )
+--import Lucid (
+--      Attribute, HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_
+--    , h1_, h2_, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_
+--    , script_, src_, title_, toHtml, toHtmlRaw, type_, ul_
+--  )
 import Markdown (Markdown(..), MarkdownContent(..))
+import Network.URL (URL)
 import Page (Page)
-import Prelude hiding (head, lookup)
+import Prelude hiding (div, head, id, lookup)
 import Pretty ((.$))
-import System.FilePath.Posix ((<.>))
+import System.FilePath.Posix ((</>), (<.>))
+import Text.Blaze.Html5 as H (
+    (!), Html, ToValue(..), body, div, docTypeHtml, h2, head, li, meta, preEscapedText, script, text, title, ul
+  )
+import Text.Blaze.Html5.Attributes (
+    charset, class_, id, src
+  )
 
-type HtmlGenerator = HtmlT (ReaderT Blog IO)
+type HtmlGenerator = ReaderT Blog IO Html
 
-class HasCard a => HasContent a where
-  content :: a -> HtmlGenerator ()
+class HasCard a => PageType a where
+  content :: a -> HtmlGenerator
+  pathToRoot :: a -> FilePath
 
-instance HasContent Article where
-  content = mDContent True . getMarkdown
+instance PageType Article where
+  content = mDContent True ".." . getMarkdown
+  pathToRoot _ = ".."
 
-instance HasContent Page where
-  content = mDContent True . getMarkdown
+instance PageType Page where
+  content = mDContent True ".." . getMarkdown
+  pathToRoot _ = ".."
 
-instance HasContent ArticlesList where
+instance PageType ArticlesList where
   content al@(ArticlesList {full}) = do
     preview <- Article.preview <$> (asks $skin.$previewLinesCount)
-    h2_ . toHtml =<< description al
+    h2_ . text =<< description al
     ul_ $ do
       asks hasRSS >>= rssLink
       li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
-    div_ [class_ "articles"] (
-        mapM_ (mDContent False . preview) =<< getArticles al
+    div [class_ "articles"] (
+        mapM_ (mDContent False (pathToRoot al) . preview) =<< getArticles al
       )
     where
       otherLink =
         toHtml <$> template (if full then "latestLink" else "allLink") []
-      rssLink :: Bool -> HtmlGenerator ()
+      rssLink :: Bool -> HtmlGenerator
       rssLink True = do
         (text, title) <- rssLinkTexts al
         li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
       rssLink False = return ()
 
-mDContent :: Bool -> Markdown -> HtmlGenerator ()
-mDContent raw markdown@(Markdown {key, body}) =
-  article_ [id_ $ pack key] (do
-      header_ . h1_ $ mDLink raw markdown
+  pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection
+
+mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator
+mDContent raw base markdown@(Markdown {key, Markdown.body}) =
+  article_ ! id (toValue key) (do
+      header_ . h1_ $ mDLink raw base markdown
       pre_ . toHtml $ unlines body
     )
 
-mDLink :: Bool -> Markdown -> HtmlGenerator ()
-mDLink raw (Markdown {Markdown.path, title}) =
-  a_ [href_ $ pack url] $ toHtml title
+mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator
+mDLink raw base (Markdown {Markdown.path, Markdown.title}) = link $ toHtml title
   where
-    url = absoluteLink $ path <.> (if raw then "md" else "html")
+    link = a_ [href_ . prefix base $ path <.> (if raw then "md" else "html")]
 
-tag :: String -> HtmlGenerator ()
-tag name =
-  a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name
+prefix :: FilePath -> FilePath -> Text
+prefix base = pack . (base </>)
 
-defaultBanner :: HtmlGenerator ()
-defaultBanner =
-  div_ [id_ "header"] (
-      a_ [href_ "/"] (
+tag :: FilePath -> String -> HtmlGenerator
+tag base name =
+  a_ [href_ . prefix base $ name ++ "/", class_ "tag"] $ toHtml name
+
+defaultBanner :: FilePath -> HtmlGenerator
+defaultBanner base =
+  div ! id "header" $
+    a_ [href_ $ pack base] (
         h1_ . toHtml =<< asks name
       )
-    )
 
-faviconLink :: FilePath -> HtmlGenerator ()
-faviconLink url = link_ [
-    rel_ "shortcut icon", href_ . pack $ absoluteLink url, type_ "image/x-icon"
+faviconLink :: FilePath -> URL -> HtmlGenerator
+faviconLink base url = link_ [
+    rel_ "shortcut icon", href_ $ localPrefix base url, type_ "image/x-icon"
   ]
 
-optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
-optional = maybe (return ()) 
+optional :: (a -> HtmlGenerator) -> Maybe a -> HtmlGenerator
+optional = maybe (return mempty) 
 
 navigationSection ::
-  Text -> String -> ((String, a) -> HtmlGenerator ()) -> Map String a -> HtmlGenerator ()
+  Text -> String -> ((String, a) -> HtmlGenerator) -> Map String a -> HtmlGenerator
 navigationSection sectionId templateKey generator collection
   | null collection = return ()
   | otherwise =
-      div_ [id_ sectionId, class_ "navigator"] (do
-          h2_ . toHtml =<< template templateKey []
-          ul_ . mapM_  (li_ . generator) $ Map.toList collection
-        )
+      div ! id sectionId ! class_ "navigator" $ do
+        h2 . toHtml =<< template templateKey []
+        ul $ (li . generator) <$> Map.toList collection
 
-htmlDocument :: HasContent a => a -> HtmlGenerator ()
+htmlDocument :: PageType a => a -> HtmlGenerator
 htmlDocument someContent =
-  doctypehtml_ (do
-      head_ (do
-          meta_ [charset_ "utf-8"]
-          title_ . toHtml =<< asks name
-          script_ [src_ "/js/remarkable.min.js"] empty
-          script_ [src_ "/js/hablo.js"] empty
-          optional faviconLink =<< (asks $skin.$favicon)
+  let base = pathToRoot someContent in
+  docTypeHtml (do
+      H.head (do
+          meta ! charset "utf-8"
+          H.title . text =<< asks name
+          script ! src (prefix base "js/remarkable.min.js") mempty
+          script ! src (prefix base "js/hablo.js") mempty
+          optional (faviconLink base) =<< (asks $skin.$favicon)
           optional (Card.make someContent) =<< (asks $urls.$cards)
-          optional toHtmlRaw =<< (asks $skin.$head)
+          optional preEscapedText =<< (asks $skin.$Blog.head)
         )
-      body_ (do
-          maybe defaultBanner toHtmlRaw =<< (asks $skin.$banner)
+      H.body (do
+          maybe (defaultBanner base) preEscapedText =<< (asks $skin.$banner)
           asks tags >>= navigationSection "tags" "tagsList"
-                          (\(key, _) -> tag key)
+                          (\(key, _) -> tag base key)
           asks pages >>= navigationSection "pages" "pagesList"
-                          (\(_, page) -> mDLink False $ getMarkdown page)
-          div_ [id_ "contents"] $ content someContent
+                          (\(_, page) -> mDLink False base $ getMarkdown page)
+          div ! id "contents" $ content someContent
         )
     )

src/DOM/Card.hs

@@ -10,48 +10,50 @@ import Article (Article(..))
 import ArticlesList (ArticlesList(..))
 import qualified ArticlesList (description)
 import Blog (Blog(..), Renderer, Skin(..), template)
+import Blog.URL (AbsoluteURL, checkURL, defaultOn, pathOn)
 import Collection (Collection(..))
 import qualified Collection (title)
 import Control.Applicative ((<|>))
 import Control.Monad.Reader (asks)
 import qualified Data.Map as Map (lookup)
 import Data.Text (Text, pack)
-import Lucid (HtmlT, content_, meta_)
-import Lucid.Base (makeAttribute)
+--import Lucid (HtmlT, content_, meta_)
+--import Lucid.Base (makeAttribute)
 import Markdown (MarkdownContent(..), metadata)
+import Network.URL (URL)
 import qualified Markdown (Markdown(..))
 import Page (Page(..))
 import Pretty ((.$))
 import System.FilePath.Posix ((</>), (<.>))
+import Text.Blaze.Html5 ((!), AttributeValue, Html, ToValue(..), meta, customAttribute)
+import Text.Blaze.Html5.Attributes as A (content)
 
 class HasCard a where
   cardType :: Renderer m => a -> m Text
   description :: Renderer m => a -> m Text
-  image :: Renderer m => a -> m (Maybe String)
+  image :: Renderer m => a -> m (Maybe URL)
   title :: Renderer m => a -> m String
   urlPath :: Renderer m => a -> m String
 
-og :: Applicative m => Text -> Text -> HtmlT m ()
-og attribute value =
-  meta_ [
-        makeAttribute "property" $ "og:" <> attribute
-      , content_ value
-    ]
+og :: Applicative m => AttributeValue -> Text -> m Html
+og attribute t =
+  pure $ meta
+    ! (customAttribute "property" $ "og:" <> attribute)
+    ! content (toValue t)
 
-make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
+make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> m Html
 make element siteURL = do
-  og "url" . sitePrefix =<< urlPath element
+  og "url" . (pathOn siteURL) =<< urlPath element
   og "type" =<< cardType element
   og "title" . pack =<< title element
   og "description" =<< description element
   maybeImage =<< ((<|>) <$> image element <*> (asks $skin.$cardImage))
   og "site_name" =<< (asks $name.$pack)
   where
-    maybeImage = maybe (return ()) (og "image" . sitePrefix)
-    sitePrefix = pack . (siteURL </>)
+    maybeImage = maybe (return mempty) (og "image" . defaultOn siteURL)
 
-mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String)
-mDImage = return . Map.lookup "featuredImage" . metadata . getMarkdown
+mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
+mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown
 
 mDTitle :: (Renderer m, MarkdownContent a) => a -> m String
 mDTitle = return . Markdown.title . getMarkdown

src/Files.hs

@@ -1,6 +1,5 @@
 module Files (
       File(..)
-    , absoluteLink
     , filePath
     , find
   ) where
@@ -10,10 +9,6 @@ import System.FilePath ((</>))
 
 data File = File FilePath | Dir FilePath
 
-absoluteLink :: FilePath -> FilePath
-absoluteLink ('.':path) = path
-absoluteLink path = "/" </> path
-
 filePath :: File -> IO (Either String FilePath)
 filePath = filePathAux
   where

src/HTML.hs

@@ -12,7 +12,7 @@ import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (ReaderT, asks)
 import qualified Data.Map as Map (elems)
 import qualified Data.Text.Lazy.IO as TextIO (writeFile)
-import DOM (HasContent, htmlDocument)
+import DOM (PageType, htmlDocument)
 import Lucid (renderTextT)
 import Markdown (Markdown(..), MarkdownContent(..))
 import Pretty ((.$))
@@ -26,7 +26,7 @@ articlesLists collection@(Collection {basePath}) = [
     file bool = if bool then "all" else "index"
     path bool = basePath </> file bool <.> "html"
 
-generateMarkdown :: (HasContent a, MarkdownContent a) => [a] -> ReaderT Blog IO ()
+generateMarkdown :: (PageType a, MarkdownContent a) => [a] -> ReaderT Blog IO ()
 generateMarkdown = mapM_ $ \content -> do
   let relativePath = Markdown.path (getMarkdown content) <.> "html"
   filePath <- (</> relativePath) <$> (asks $Blog.path.$root)

src/JSON.hs

@@ -4,7 +4,7 @@ module JSON (
     exportBlog
   ) where
 
-import Blog (Blog, Path, Skin, URL, Wording)
+import Blog (Blog, Path, Skin, URLs, Wording)
 import qualified Blog (Blog(..))
 import Data.Aeson (Options(..), ToJSON(..), genericToEncoding, defaultOptions)
 import Data.Map (Map, mapWithKey)
@@ -39,7 +39,7 @@ data BlogExport = BlogExport {
     , pages :: Map String MarkdownExport
     , skin :: Skin
     , tags :: Map String [String]
-    , urls :: URL
+    , urls :: URLs
     , wording :: Wording
   } deriving (Generic)
 

src/RSS.hs

@@ -7,24 +7,26 @@ module RSS (
 
 import Article (Article(..))
 import ArticlesList (ArticlesList(..), getArticles)
-import qualified ArticlesList (description)
-import Blog (Blog(urls), Renderer, URL(..))
+import qualified ArticlesList (description, path)
+import Blog (Blog(urls), Renderer, URLs(..))
+import Blog.URL (AbsoluteURL, pathOn)
 import Collection (Collection(..), getAll)
 import qualified Collection (title)
 import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Reader (MonadReader, ReaderT, asks)
+import Control.Monad.Reader (ReaderT, asks)
 import Data.Text (Text)
 import Data.Map ((!))
 import qualified Data.Text.Lazy.IO as TextIO (writeFile)
 import Data.Time (defaultTimeLocale, formatTime, rfc822DateFormat)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
-import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT)
+--import Lucid (Attribute, HtmlT, Term, ToHtml(..), term, renderTextT)
 import Lucid.Base (makeAttribute)
 import Markdown (Markdown(..))
 import Pretty ((.$))
 import System.FilePath.Posix ((</>), (<.>))
+import Text.Blaze.Html (Html)
 
-prolog :: Monad m => HtmlT m ()
+prolog :: Monad m => m Html
 prolog = toHtmlRaw ("<?xml  version=\"1.0\" encoding=\"UTF-8\" ?>" :: String)
 
 version_ :: Text -> Attribute
@@ -57,24 +59,24 @@ item_ = term "item"
 pubDate_ :: Term arg result => arg -> result
 pubDate_ = term "pubDate"
 
-articleItem :: MonadReader Blog m => String -> Article -> HtmlT m ()
+articleItem :: Monad m => AbsoluteURL -> Article -> m Html
 articleItem siteURL (Article (Markdown {path, metadata, title})) =
   item_ $ do
     title_ $ toHtml title
-    link_ $ toHtml (siteURL </> path <.> "html")
+    link_ . toHtml $ pathOn siteURL (path <.> "html")
     pubDate_ . toHtml . rfc822Date $ metadata ! "date"
   where
     rfc822Date =
         formatTime defaultTimeLocale rfc822DateFormat
       . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
 
-feed :: Renderer m => String -> ArticlesList -> HtmlT m ()
+feed :: Renderer m => AbsoluteURL -> ArticlesList -> m Html
 feed siteURL al@(ArticlesList {collection}) = do
   prolog
   rss_ [version, content, atom] $ do
     channel_ $ do
       title_ . toHtml =<< Collection.title collection
-      link_ . toHtml $ siteURL </> maybe "" (++ "/") (tag collection)
+      link_ . toHtml . pathOn siteURL $ ArticlesList.path al
       description_ . toHtml =<< ArticlesList.description al
       mapM_ (articleItem siteURL) =<< getArticles al
   where
@@ -82,7 +84,7 @@ feed siteURL al@(ArticlesList {collection}) = do
     content = xmlns_content_ "http://purl.org/rss/1.0/modules/content/"
     atom = xmlns_atom_ "http://www.w3.org/2005/Atom"
 
-generateCollection :: String -> Collection -> ReaderT Blog IO ()
+generateCollection :: AbsoluteURL -> Collection -> ReaderT Blog IO ()
 generateCollection siteURL collection =
   renderTextT (feed siteURL $ ArticlesList {full = False, collection})
   >>= liftIO . TextIO.writeFile (basePath collection </> "rss" <.> "xml")

test/Mock/Article.hs

@@ -1,12 +1,14 @@
 module Mock.Article (
-      noDescription
+      hostRelativeImage
+    , noDescription
     , noImage
     , noMeta
+    , remoteImage
     , simple
   ) where
 
 import Article (Article(..))
-import qualified Data.Map as Map (fromList)
+import qualified Data.Map as Map (fromList, insert)
 import Markdown (Markdown(..))
 import Mock.Markdown (article)
 
@@ -16,6 +18,16 @@ simple = Article article
 noImage :: Article
 noImage = Article $ article {metadata = Map.fromList [("summary", "It's a test")]}
 
+remoteImage :: Article
+remoteImage = Article $ article {metadata = setImage $ metadata article}
+  where
+    setImage = Map.insert "featuredImage" "https://somewhere.el.se/test.png"
+
+hostRelativeImage :: Article
+hostRelativeImage = Article $ article {metadata = setImage $ metadata article}
+  where
+    setImage = Map.insert "featuredImage" "/media/test.png"
+
 noDescription :: Article
 noDescription = Article $ article {metadata = Map.fromList [("featuredImage", "test.png")]}
 

test/Mock/Blog.hs

@@ -3,6 +3,7 @@ module Mock.Blog (
       noCards
     , noRSS
     , simple
+    , subPath
   ) where
 
 import Blog (Blog(..))
@@ -12,7 +13,7 @@ import qualified Mock.Article (simple)
 import qualified Mock.Blog.Path (defaultArticles)
 import qualified Mock.Blog.Skin (simple)
 import qualified Mock.Blog.Template (simple)
-import qualified Mock.Blog.URL (simple, noCards)
+import qualified Mock.Blog.URL (simple, subPath, noCards)
 import qualified Mock.Blog.Wording (defaultWording)
 
 simple :: IO Blog
@@ -32,6 +33,9 @@ simple =
       , wording
     }
 
+subPath :: IO Blog
+subPath = (\b -> b {urls = Mock.Blog.URL.subPath}) <$> simple
+
 noCards :: IO Blog
 noCards = (\b -> b {urls = Mock.Blog.URL.noCards}) <$> simple
 

test/Mock/Blog/URL.hs

@@ -1,16 +1,25 @@
 module Mock.Blog.URL (
       noCards
     , simple
+    , subPath
   ) where
 
-import Blog.URL (URL(..))
+import Blog.URL (URLs(..))
+import Mock.URL (prefixedTestSite, testSite)
 
-simple :: URL
-simple = URL {
-      cards = Just "https://test.net"
+simple :: URLs
+simple = URLs {
+      cards = Just testSite
     , comments = Nothing
     , rss = Nothing
   }
 
-noCards :: URL
+subPath :: URLs
+subPath = URLs {
+      cards = Just prefixedTestSite
+    , comments = Nothing
+    , rss = Nothing
+  }
+
+noCards :: URLs
 noCards = simple {cards = Nothing}

test/Mock/URL.hs

@@ -0,0 +1,60 @@
+module Mock.URL (
+      cdnFavicon
+    , hostFavicon
+    , localDiscovered
+    , localFavicon
+    , prefixedTestSite
+    , testHost
+    , testSite
+  ) where
+
+import Blog.URL (AbsoluteURL(..))
+import Network.URL (Host(..), Protocol(..), URL(..), URLType(..))
+
+testHost :: Host
+testHost = Host (HTTP True) "test.net" Nothing
+
+testSite :: AbsoluteURL
+testSite = AbsoluteURL {
+      Blog.URL.host = testHost
+    , urlPath = ""
+    , urlParams = []
+  }
+
+prefixedTestSite :: AbsoluteURL
+prefixedTestSite = AbsoluteURL {
+        Blog.URL.host = testHost
+      , urlPath = "subPath"
+      , urlParams = []
+  }
+
+cdn :: Host
+cdn = Host (HTTP True) "cdn.net" Nothing
+
+cdnFavicon :: URL
+cdnFavicon = URL {
+      url_type = Absolute cdn
+    , url_path = "favicon.png"
+    , url_params = []
+  }
+
+hostFavicon :: URL
+hostFavicon = URL {
+      url_type = HostRelative
+    , url_path = "favicon.png"
+    , url_params = []
+  }
+
+localFavicon :: URL
+localFavicon = URL {
+      url_type = PathRelative
+    , url_path = "favicon.png"
+    , url_params = []
+  }
+
+localDiscovered :: URL
+localDiscovered = URL {
+      url_type = PathRelative
+    , url_path = "skin/favicon.png"
+    , url_params = []
+  }

test/Tests.hs

@@ -4,11 +4,15 @@ module Tests (
 
 import Distribution.TestSuite
 import qualified Structure (test)
+import qualified URLs (test)
 import Utils (tag)
 import qualified XML.Card (test)
+import qualified XML.Favicon (test)
 
 tests :: IO [Test]
 tests = return $ tag "xml" <$> [
       XML.Card.test
+    , XML.Favicon.test
     , Structure.test
+    , URLs.test
   ]

test/URLs.hs

@@ -0,0 +1,73 @@
+{-# LANGUAGE OverloadedStrings #-}
+module URLs (
+    test
+  ) where
+
+import Blog.URL (defaultOn, pathOn, localPrefix)
+import Data.Text (Text)
+import Distribution.TestSuite
+import Mock.URL (
+      cdnFavicon, hostFavicon, localDiscovered, localFavicon, prefixedTestSite
+    , testSite
+  )
+import Utils (simpleTest, tag)
+
+check :: Text -> Text -> IO Progress
+check actual expected =
+  return . Finished $
+    if actual == expected
+    then Pass
+    else Fail $ "Expected " ++ show expected ++ " but got " ++ show actual
+
+testPathOn :: Test
+testPathOn = tag "pathOn" . testGroup "Concat path" $ simpleTest <$> [
+      ("no prefix / relative path",
+        check (pathOn testSite "tag/all.html") "https://test.net/tag/all.html")
+    , ("no prefix / absolute path",
+        check
+          (pathOn testSite "/media/logo.png")
+          "https://test.net/media/logo.png")
+    , ("prefixed / relative path",
+        check
+          (pathOn prefixedTestSite "tag/all.html")
+          "https://test.net/subPath/tag/all.html")
+    , ("prefixed / absolute path ",
+        check
+          (pathOn prefixedTestSite "/media/logo.png")
+          "https://test.net/media/logo.png")
+  ]
+
+testDefaultOn :: Test
+testDefaultOn = tag "defaultOn" . testGroup "Concat path or pick URL" $ simpleTest <$> [
+      ("external resource", -- shouldn't even touch the first argument when the second is an absolute URL
+        check (defaultOn undefined cdnFavicon) "https://cdn.net/favicon.png")
+    , ("host relative",
+        check (defaultOn testSite hostFavicon) "https://test.net/favicon.png")
+    , ("host relative / prefix",
+        check
+          (defaultOn prefixedTestSite hostFavicon)
+          "https://test.net/favicon.png")
+    , ("relative",
+        check
+          (defaultOn testSite localDiscovered)
+          "https://test.net/skin/favicon.png")
+    , ("relative / prefix",
+        check
+          (defaultOn prefixedTestSite localDiscovered)
+          "https://test.net/subPath/skin/favicon.png")
+  ]
+
+testLocalPrefix :: Test
+testLocalPrefix = tag "localPrefix" . testGroup "Prefixed URLs" $ simpleTest <$> [
+      ("absolute URL", check (localPrefix ".." cdnFavicon) "https://cdn.net/favicon.png")
+    , ("host relative", check (localPrefix ".." hostFavicon) "/favicon.png")
+    , ("relative path", check (localPrefix ".." localDiscovered) "../skin/favicon.png")
+    , ("relative path no prefix", check (localPrefix "" localFavicon) "favicon.png")
+  ]
+
+test :: Test
+test = tag "URLs" $ testGroup "URLs handling" [
+      testPathOn
+    , testDefaultOn
+    , testLocalPrefix
+  ]

test/XML/Card/Component.hs

@@ -4,6 +4,7 @@ module XML.Card.Component (
   ) where
 
 import Blog (Blog)
+import Blog.URL (pathRelative)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (runReaderT)
 import Data.Text (Text)
@@ -14,9 +15,10 @@ import Mock.Article as Article (noDescription, noImage, simple)
 import Mock.ArticlesList as ArticlesList (
     longMain, longTesting, shortMain, shortTesting
   )
+import Network.URL (URL)
 import Utils (assertAll, assertEqual, simpleTest, tag)
 
-check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress
+check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe URL, String, String) -> IO Progress
 check getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) =
   getBlog >>= runReaderT (
       sequence [
@@ -33,14 +35,14 @@ articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
       ("simple article components", check Blog.simple Article.simple (
             "article"
           , "It's a test"
-          , Just "test.png"
+          , Just (pathRelative "test.png")
           , "Some test"
           , "articles/test.html"
         ))
     , ("article components without description", check Blog.simple Article.noDescription (
             "article"
           , "A new article on The Test Blog"
-          , Just "test.png"
+          , Just (pathRelative "test.png")
           , "Some test"
           , "articles/test.html"
         ))

test/XML/Card/Output.hs

@@ -2,15 +2,17 @@ module XML.Card.Output (
     test
   ) where
 
-import Blog (Blog(..), URL(..))
+import Blog (Blog(..), URLs(..))
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Reader (asks, runReaderT)
 import qualified Data.Text.Lazy.IO as Lazy (readFile)
 import Distribution.TestSuite
 import DOM.Card (HasCard(..), make)
 import Lucid (renderTextT)
-import Mock.Blog as Blog (noCards, simple)
-import Mock.Article as Article (noDescription, noImage, simple)
+import Mock.Blog as Blog (noCards, simple, subPath)
+import Mock.Article as Article (
+    hostRelativeImage, noDescription, noImage, remoteImage, simple
+  )
 import Mock.ArticlesList as ArticlesList (
     longMain, longTesting, shortMain, shortTesting
   )
@@ -31,8 +33,15 @@ check getBlog input expectedFile =
 articleCard :: Test 
 articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
       ("simple article output", check Blog.simple Article.simple "simple.html")
-    , ("article output without description", check Blog.simple Article.noDescription "noDescription.html")
-    , ("article output without image", check Blog.simple Article.noImage "noImage.html")
+    , ("simple article output with subPath", check Blog.subPath Article.simple "subPath.html")
+    , ("article output without description"
+      , check Blog.simple Article.noDescription "noDescription.html")
+    , ("article output without image"
+      , check Blog.simple Article.noImage "noImage.html")
+    , ("article output with an image on a remote server"
+      , check Blog.simple Article.remoteImage "remoteImage.html")
+    , ("article output with an image in a host-relative folder"
+      , check Blog.simple Article.hostRelativeImage "hostRelativeImage.html")
     , ("no card article output", check Blog.noCards Article.simple "/dev/null")
   ]
 

test/XML/Card/Output/hostRelativeImage.html

@@ -0,0 +1 @@
+<meta property="og:url" content="https://test.net/articles/test.html"><meta property="og:type" content="article"><meta property="og:title" content="Some test"><meta property="og:description" content="It&#39;s a test"><meta property="og:image" content="https://test.net/media/test.png"><meta property="og:site_name" content="The Test Blog">

test/XML/Card/Output/remoteImage.html

@@ -0,0 +1 @@
+<meta property="og:url" content="https://test.net/articles/test.html"><meta property="og:type" content="article"><meta property="og:title" content="Some test"><meta property="og:description" content="It&#39;s a test"><meta property="og:image" content="https://somewhere.el.se/test.png"><meta property="og:site_name" content="The Test Blog">

test/XML/Card/Output/subPath.html

@@ -0,0 +1 @@
+<meta property="og:url" content="https://test.net/subPath/articles/test.html"><meta property="og:type" content="article"><meta property="og:title" content="Some test"><meta property="og:description" content="It&#39;s a test"><meta property="og:image" content="https://test.net/subPath/test.png"><meta property="og:site_name" content="The Test Blog">

test/XML/Favicon.hs

@@ -0,0 +1,27 @@
+module XML.Favicon (
+    test
+  ) where
+
+import Blog.Skin (findImage)
+import Distribution.TestSuite
+import Mock.URL (cdnFavicon, hostFavicon, localDiscovered, localFavicon)
+import Network.URL (URL)
+import System.Directory (withCurrentDirectory)
+import Utils (assertAll, assertEqual, simpleTest, tag, testDataPath)
+
+check :: IO (Maybe URL) -> Maybe URL -> IO Progress
+check getter expected =
+  withCurrentDirectory (testDataPath "XML/Favicon/Input") $ do
+    actual <- getter
+    assertAll $ [
+        assertEqual "URLs" actual expected
+      ]
+
+test :: Test
+test = tag "favicon" . testGroup "Favicons" $ simpleTest <$> [
+      ("auto-discover", check (findImage "favicon" Nothing) (Just localDiscovered))
+    , ("none", check (findImage "blerp" Nothing) Nothing)
+    , ("manual absolute", check (findImage "" (Just "https://cdn.net/favicon.png")) (Just cdnFavicon))
+    , ("manual host-relative", check (findImage "" (Just "/favicon.png")) (Just hostFavicon))
+    , ("manual relative", check (findImage "" (Just "favicon.png")) (Just localFavicon))
+  ]