Add a development package for guix and fix SJW incompatibility since

the 0.1.3.1 bugfix

ghc-template.scm

@@ -0,0 +1,27 @@
+(use-modules (gnu packages haskell-xyz)
+             (gnu packages haskell-web)
+             (guix build-system haskell)
+             (guix download)
+             (guix gexp)
+             (guix git-download)
+             (guix licenses)
+             (guix packages))
+
+(package
+  (name "ghc-template")
+  (version "0.2.0.10")
+  (source (origin
+            (method url-fetch)
+            (uri (hackage-uri "template" version))
+            (sha256
+             (base32
+              "10mcnhi2rdflmv79z0359nn5sylifvk9ih38xnjqqby6n4hs7mcg"))))
+  (build-system haskell-build-system)
+  (properties '((upstream-name . "template")))
+  (home-page "http://hackage.haskell.org/package/template")
+  (synopsis "Simple string substitution")
+  (description
+   "Simple string substitution library that supports \\\"$\\\"-based substitution.
+Meant to be used when Text.Printf or string concatenation would lead to code
+that is hard to read but when a full blown templating system is overkill.")
+  (license bsd-3))

guix.scm

@@ -0,0 +1,44 @@
+(use-modules (gnu packages haskell-xyz)
+             (gnu packages haskell-web)
+             (guix build-system haskell)
+             (guix download)
+             (guix gexp)
+             (guix git-download)
+             (guix licenses)
+             (guix packages)
+             (loom packages sjw))
+
+(let
+  ((%source-dir (dirname (current-filename)))
+   (ghc-template (load "ghc-template.scm")))
+  (package
+    (name "hablo")
+    (version "devel")
+    (source
+    (local-file %source-dir
+          #:recursive? #t
+          #:select? (git-predicate %source-dir)))
+    (build-system haskell-build-system)
+    (inputs
+      (list ghc-aeson
+            ghc-attoparsec
+            ghc-lucid
+            ghc-optparse-applicative
+            ghc-parsec
+            ghc-random
+            ghc-sjw
+            ghc-template
+            ghc-xdg-basedir))
+    (native-search-paths
+      (list
+        (search-path-specification (variable "SJW_PATH")
+                                   (files '("lib/SJW")))))
+    (home-page "https://git.marvid.fr/Tissevert/SJW")
+    (synopsis "The Simple Javascript Wrench")
+    (description
+     "SJW is a very simple tool to pack several JS modules into a single
+     script.  It doesn't really do proper compilation work (yet) except
+     resolving the modules dependencies and detecting import loops but it
+     provides each module with an independent execution context in the
+     resulting script.")
+    (license gpl3+)))

hablo.cabal

@@ -50,23 +50,21 @@ library
                      , Pretty
                      , RSS
   -- other-extensions:
-  build-depends:       aeson >= 1.2.0 && < 1.6
+  build-depends:       aeson >= 1.2.0 && < 2.1
-                     , base >= 4.9.1 && < 4.16
+                     , base >= 4.9.1 && < 4.17
                      , bytestring >= 0.10.8 && < 0.12
                      , containers >= 0.5.11 && < 0.7
                      , directory >= 1.3.1 && < 1.4
                      , filepath >= 1.4.2 && < 1.5
-                     , blaze-html
+                     , lucid >= 2.8.0 && < 2.12
-                     , blaze-markup
                      , mtl >= 2.2.2 && < 2.3
-                     , optparse-applicative >= 0.14.0 && < 0.17
+                     , optparse-applicative >= 0.14.0 && < 0.18
                      , parsec >= 3.1.13 && < 3.2
                      , template >= 0.2.0 && < 0.3
                      , text >= 1.2.3 && < 1.3
                      , 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
@@ -77,7 +75,7 @@ executable hablo
   -- other-extensions:
   build-depends:       base
                      , hablo
-                     , mtl
+                     , mtl >= 2.2.2 && < 2.3
   ghc-options:         -Wall
   default-language:    Haskell2010
 
@@ -95,14 +93,11 @@ 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
@@ -112,7 +107,6 @@ test-suite tests
                      , lucid
                      , mtl
                      , text
-                     , url
   hs-source-dirs:      test
   ghc-options:         -Wall
   default-language:    Haskell2010

src/ArticlesList.hs

@@ -6,7 +6,6 @@ module ArticlesList (
     , description
     , getArticles
     , otherURL
-    , ArticlesList.path
     , rssLinkTexts
   ) where
 
@@ -15,7 +14,9 @@ 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
@@ -27,8 +28,9 @@ getArticles (ArticlesList {full, collection = Collection {featured}}) = do
   limit <- take <$> (asks $skin.$previewArticlesCount)
   return $ if full then featured else limit featured
 
-otherURL :: ArticlesList -> FilePath
+otherURL :: ArticlesList -> String
-otherURL (ArticlesList {full}) = if full then "." else "all.html"
+otherURL (ArticlesList {full, collection}) = absoluteLink $
+  (if full then id else (</> "all.html")) . maybe "" id $ tag collection
 
 description :: Renderer m => ArticlesList -> m Text
 description (ArticlesList {full, collection}) =
@@ -44,6 +46,3 @@ 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(..)
-    , URLs(..)
+    , URL(..)
     , 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 (URLs(..))
+import Blog.URL (URL(..))
 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 :: URLs
+    , urls :: URL
     , wording :: Wording
   }
 

src/Blog/Skin.hs

@@ -1,49 +1,45 @@
+{-# 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(..), (.=), object, pairs)
+import Data.Aeson (ToJSON(..), (.=), pairs)
 import Data.Maybe (listToMaybe)
 #if !MIN_VERSION_base(4,11,0)
 import Data.Monoid ((<>))
 #endif
-import Network.URL (URL)
+import Files (absoluteLink)
+import GHC.Generics (Generic)
 import Prelude hiding (head)
 import System.Directory (doesFileExist)
 import System.FilePath ((</>), (<.>))
 
 data Skin = Skin {
       banner :: Maybe String
-    , cardImage :: Maybe URL
+    , cardImage :: Maybe FilePath
-    , favicon :: Maybe URL
+    , favicon :: Maybe FilePath
     , 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 URL)
+findImage :: String -> Maybe FilePath -> IO (Maybe FilePath)
-findImage _ (Just path) = Just <$> checkURL path
+findImage _ (Just path) = return . Just $ absoluteLink path
 findImage name Nothing =
-  fmap pathRelative . listToMaybe <$> filterM doesFileExist pathsToCheck
+  listToMaybe <$> filterM doesFileExist pathsToCheck
   where
     directories = [".", "image", "images", "pictures", "skin", "static"]
     extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"]

src/Blog/URL.hs

@@ -1,113 +1,45 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Blog.URL (
-      AbsoluteURL(..)
+      URL(..)
-    , 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(..), (.=), pairs)
-import Data.Aeson (ToJSON(..), (.=), object, pairs)
+import GHC.Generics (Generic)
-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 {
+data URL = URL {
-      host :: Host
+      cards :: Maybe String
-    , urlPath :: FilePath
+    , comments :: Maybe String
-    , urlParams :: [(String, String)]
+    , rss :: Maybe String
-  }
+  } deriving Generic
 
-toText :: AbsoluteURL -> Text
+instance ToJSON URL where
-toText (AbsoluteURL {host, urlPath, urlParams}) =
+  toEncoding (URL {comments}) = pairs (
-  pack . exportURL $ URL (Absolute host) urlPath urlParams
+      "comments" .= comments
-
-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
+build :: Arguments -> IO 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")
+  cards <- getSiteURL argOGCards "Open Graph cards"
-  rss <- getURL (Just argRSS) siteURL (failBecauseOf "RSS feeds")
+  rss <- getSiteURL argRSS "RSS feeds"
-  comments <- getURL Nothing commentsURL (pure Nothing)
   checksUsed (argOGCards || argRSS) siteURL
-  return $ URLs {cards, comments, rss}
+  return $ URL {cards, comments, rss}
   where
-    commentsURL = Arguments.commentsURL arguments
+    comments = Arguments.commentsURL arguments
     siteURL = Arguments.siteURL arguments
     argOGCards = Arguments.openGraphCards arguments
     argRSS = Arguments.rss arguments
-    failBecauseOf :: String -> IO a
+    errorMsg :: String -> String
-    failBecauseOf =
+    errorMsg = printf "Enabling %s requires setting the site url with --site-url"
-      die . 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
-pathRelative :: String -> URL
+    checksUsed False (Just _) =
-pathRelative url_path = URL {url_type = PathRelative, url_path, url_params = []}
+      hPutStrLn stderr "Site url is set but not used, did you forget --open-graph-cards or --rss ?"
-
+    checksUsed _ _ = return ()
-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 (
-      PageType(..)
+      HasContent(..)
     , htmlDocument
   ) where
 
@@ -10,129 +10,115 @@ import qualified Article (preview)
 import ArticlesList (
     ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
   )
-import Blog (Blog(..), Skin(..), URLs(..), template)
+import Blog (Blog(..), Skin(..), URL(..), 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 Lucid (
+import Files (absoluteLink)
---      Attribute, HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_
+import Lucid (
---    , h1_, h2_, head_, header_, href_, li_, link_, id_, meta_, pre_, rel_
+      HtmlT, a_, article_, body_, charset_, class_, div_, doctypehtml_, h1_, h2_
---    , script_, src_, title_, toHtml, toHtmlRaw, type_, ul_
+    , 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 (div, head, id, lookup)
+import Prelude hiding (head, 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 = ReaderT Blog IO Html
+type HtmlGenerator = HtmlT (ReaderT Blog IO)
 
-class HasCard a => PageType a where
+class HasCard a => HasContent a where
-  content :: a -> HtmlGenerator
+  content :: a -> HtmlGenerator ()
-  pathToRoot :: a -> FilePath
 
-instance PageType Article where
+instance HasContent Article where
-  content = mDContent True ".." . getMarkdown
+  content = mDContent True . getMarkdown
-  pathToRoot _ = ".."
 
-instance PageType Page where
+instance HasContent Page where
-  content = mDContent True ".." . getMarkdown
+  content = mDContent True . getMarkdown
-  pathToRoot _ = ".."
 
-instance PageType ArticlesList where
+instance HasContent ArticlesList where
   content al@(ArticlesList {full}) = do
     preview <- Article.preview <$> (asks $skin.$previewLinesCount)
-    h2_ . text =<< description al
+    h2_ . toHtml =<< description al
     ul_ $ do
       asks hasRSS >>= rssLink
       li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
-    div [class_ "articles"] (
+    div_ [class_ "articles"] (
-        mapM_ (mDContent False (pathToRoot al) . preview) =<< getArticles al
+        mapM_ (mDContent False . 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 ()
 
-  pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection
+mDContent :: Bool -> Markdown -> HtmlGenerator ()
-
+mDContent raw markdown@(Markdown {key, body}) =
-mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator
+  article_ [id_ $ pack key] (do
-mDContent raw base markdown@(Markdown {key, Markdown.body}) =
+      header_ . h1_ $ mDLink raw markdown
-  article_ ! id (toValue key) (do
-      header_ . h1_ $ mDLink raw base markdown
       pre_ . toHtml $ unlines body
     )
 
-mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator
+mDLink :: Bool -> Markdown -> HtmlGenerator ()
-mDLink raw base (Markdown {Markdown.path, Markdown.title}) = link $ toHtml title
+mDLink raw (Markdown {Markdown.path, title}) =
+  a_ [href_ $ pack url] $ toHtml title
   where
-    link = a_ [href_ . prefix base $ path <.> (if raw then "md" else "html")]
+    url = absoluteLink $ path <.> (if raw then "md" else "html")
 
-prefix :: FilePath -> FilePath -> Text
+tag :: String -> HtmlGenerator ()
-prefix base = pack . (base </>)
+tag name =
+  a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name
 
-tag :: FilePath -> String -> HtmlGenerator
+defaultBanner :: HtmlGenerator ()
-tag base name =
+defaultBanner =
-  a_ [href_ . prefix base $ name ++ "/", class_ "tag"] $ toHtml name
+  div_ [id_ "header"] (
+      a_ [href_ "/"] (
+          h1_ . toHtml =<< asks name
+        )
+    )
 
-defaultBanner :: FilePath -> HtmlGenerator
+faviconLink :: FilePath -> HtmlGenerator ()
-defaultBanner base =
+faviconLink url = link_ [
-  div ! id "header" $
+    rel_ "shortcut icon", href_ . pack $ absoluteLink url, type_ "image/x-icon"
-    a_ [href_ $ pack base] (
-        h1_ . toHtml =<< asks name
-      )
-
-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 :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
-optional = maybe (return mempty) 
+optional = maybe (return ()) 
 
 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
+      div_ [id_ sectionId, class_ "navigator"] (do
-        h2 . toHtml =<< template templateKey []
+          h2_ . toHtml =<< template templateKey []
-        ul $ (li . generator) <$> Map.toList collection
+          ul_ . mapM_  (li_ . generator) $ Map.toList collection
-
-htmlDocument :: PageType a => a -> HtmlGenerator
-htmlDocument someContent =
-  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 preEscapedText =<< (asks $skin.$Blog.head)
         )
-      H.body (do
+
-          maybe (defaultBanner base) preEscapedText =<< (asks $skin.$banner)
+htmlDocument :: HasContent 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)
+          optional (Card.make someContent) =<< (asks $urls.$cards)
+          optional toHtmlRaw =<< (asks $skin.$head)
+        )
+      body_ (do
+          maybe defaultBanner toHtmlRaw =<< (asks $skin.$banner)
           asks tags >>= navigationSection "tags" "tagsList"
-                          (\(key, _) -> tag base key)
+                          (\(key, _) -> tag key)
           asks pages >>= navigationSection "pages" "pagesList"
-                          (\(_, page) -> mDLink False base $ getMarkdown page)
+                          (\(_, page) -> mDLink False $ getMarkdown page)
-          div ! id "contents" $ content someContent
+          div_ [id_ "contents"] $ content someContent
         )
     )

src/DOM/Card.hs

@@ -10,50 +10,48 @@ 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 (HtmlT, content_, meta_)
---import Lucid.Base (makeAttribute)
+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 URL)
+  image :: Renderer m => a -> m (Maybe String)
   title :: Renderer m => a -> m String
   urlPath :: Renderer m => a -> m String
 
-og :: Applicative m => AttributeValue -> Text -> m Html
+og :: Applicative m => Text -> Text -> HtmlT m ()
-og attribute t =
+og attribute value =
-  pure $ meta
+  meta_ [
-    ! (customAttribute "property" $ "og:" <> attribute)
+        makeAttribute "property" $ "og:" <> attribute
-    ! content (toValue t)
+      , content_ value
+    ]
 
-make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> m Html
+make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
 make element siteURL = do
-  og "url" . (pathOn siteURL) =<< urlPath element
+  og "url" . sitePrefix =<< 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 mempty) (og "image" . defaultOn siteURL)
+    maybeImage = maybe (return ()) (og "image" . sitePrefix)
+    sitePrefix = pack . (siteURL </>)
 
-mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
+mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String)
-mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown
+mDImage = return . Map.lookup "featuredImage" . metadata . getMarkdown
 
 mDTitle :: (Renderer m, MarkdownContent a) => a -> m String
 mDTitle = return . Markdown.title . getMarkdown

src/Files.hs

@@ -1,5 +1,6 @@
 module Files (
       File(..)
+    , absoluteLink
     , filePath
     , find
   ) where
@@ -9,6 +10,10 @@ 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 (PageType, htmlDocument)
+import DOM (HasContent, 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 :: (PageType a, MarkdownContent a) => [a] -> ReaderT Blog IO ()
+generateMarkdown :: (HasContent 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/JS.hs

@@ -16,7 +16,7 @@ import Data.Text.Encoding (encodeUtf8)
 import JSON (exportBlog)
 import Paths_hablo (getDataDir)
 import Pretty ((.$))
-import SJW (compile, source, sourceCode)
+import SJW (compile, source)
 import System.Directory (createDirectoryIfMissing)
 import System.Exit (die)
 import System.FilePath ((</>))
@@ -45,10 +45,11 @@ generateConfig destinationDir = do
 generateMain :: FilePath -> IO ()
 generateMain destinationDir = do
   habloSources <- (</> "js") <$> getDataDir
-  result <- compile $ source [destinationDir, "unitJS", habloSources]
+  compile (source [destinationDir, "unitJS", habloSources])
-  maybe (die "JS compilation failed\n") output =<< sourceCode result
+    >>= either abort (output . fst)
   where
     output = writeFile (destinationDir </> "hablo.js") . fromStrict . encodeUtf8
+    abort = die . (<> "JS compilation failed\n")
 
 generate :: ReaderT Blog IO ()
 generate = do

src/JSON.hs

@@ -4,7 +4,7 @@ module JSON (
     exportBlog
   ) where
 
-import Blog (Blog, Path, Skin, URLs, Wording)
+import Blog (Blog, Path, Skin, URL, 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 :: URLs
+    , urls :: URL
     , wording :: Wording
   } deriving (Generic)
 

src/RSS.hs

@@ -7,26 +7,24 @@ module RSS (
 
 import Article (Article(..))
 import ArticlesList (ArticlesList(..), getArticles)
-import qualified ArticlesList (description, path)
+import qualified ArticlesList (description)
-import Blog (Blog(urls), Renderer, URLs(..))
+import Blog (Blog(urls), Renderer, URL(..))
-import Blog.URL (AbsoluteURL, pathOn)
 import Collection (Collection(..), getAll)
 import qualified Collection (title)
 import Control.Monad.IO.Class (MonadIO(..))
-import Control.Monad.Reader (ReaderT, asks)
+import Control.Monad.Reader (MonadReader, 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 => m Html
+prolog :: Monad m => HtmlT m ()
 prolog = toHtmlRaw ("<?xml  version=\"1.0\" encoding=\"UTF-8\" ?>" :: String)
 
 version_ :: Text -> Attribute
@@ -59,24 +57,24 @@ item_ = term "item"
 pubDate_ :: Term arg result => arg -> result
 pubDate_ = term "pubDate"
 
-articleItem :: Monad m => AbsoluteURL -> Article -> m Html
+articleItem :: MonadReader Blog m => String -> Article -> HtmlT m ()
 articleItem siteURL (Article (Markdown {path, metadata, title})) =
   item_ $ do
     title_ $ toHtml title
-    link_ . toHtml $ pathOn siteURL (path <.> "html")
+    link_ $ toHtml (siteURL </> path <.> "html")
     pubDate_ . toHtml . rfc822Date $ metadata ! "date"
   where
     rfc822Date =
         formatTime defaultTimeLocale rfc822DateFormat
       . posixSecondsToUTCTime . fromIntegral . (read :: String -> Int)
 
-feed :: Renderer m => AbsoluteURL -> ArticlesList -> m Html
+feed :: Renderer m => String -> ArticlesList -> HtmlT m ()
 feed siteURL al@(ArticlesList {collection}) = do
   prolog
   rss_ [version, content, atom] $ do
     channel_ $ do
       title_ . toHtml =<< Collection.title collection
-      link_ . toHtml . pathOn siteURL $ ArticlesList.path al
+      link_ . toHtml $ siteURL </> maybe "" (++ "/") (tag collection)
       description_ . toHtml =<< ArticlesList.description al
       mapM_ (articleItem siteURL) =<< getArticles al
   where
@@ -84,7 +82,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 :: AbsoluteURL -> Collection -> ReaderT Blog IO ()
+generateCollection :: String -> 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,14 +1,12 @@
 module Mock.Article (
-      hostRelativeImage
+      noDescription
-    , noDescription
     , noImage
     , noMeta
-    , remoteImage
     , simple
   ) where
 
 import Article (Article(..))
-import qualified Data.Map as Map (fromList, insert)
+import qualified Data.Map as Map (fromList)
 import Markdown (Markdown(..))
 import Mock.Markdown (article)
 
@@ -18,16 +16,6 @@ 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,7 +3,6 @@ module Mock.Blog (
       noCards
     , noRSS
     , simple
-    , subPath
   ) where
 
 import Blog (Blog(..))
@@ -13,7 +12,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, subPath, noCards)
+import qualified Mock.Blog.URL (simple, noCards)
 import qualified Mock.Blog.Wording (defaultWording)
 
 simple :: IO Blog
@@ -33,9 +32,6 @@ 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,25 +1,16 @@
 module Mock.Blog.URL (
       noCards
     , simple
-    , subPath
   ) where
 
-import Blog.URL (URLs(..))
+import Blog.URL (URL(..))
-import Mock.URL (prefixedTestSite, testSite)
 
-simple :: URLs
+simple :: URL
-simple = URLs {
+simple = URL {
-      cards = Just testSite
+      cards = Just "https://test.net"
     , comments = Nothing
     , rss = Nothing
   }
 
-subPath :: URLs
+noCards :: URL
-subPath = URLs {
-      cards = Just prefixedTestSite
-    , comments = Nothing
-    , rss = Nothing
-  }
-
-noCards :: URLs
 noCards = simple {cards = Nothing}

test/Mock/URL.hs

@@ -1,60 +0,0 @@
-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,15 +4,11 @@ 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

@@ -1,73 +0,0 @@
-{-# 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,7 +4,6 @@ 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)
@@ -15,10 +14,9 @@ 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 URL, String, String) -> IO Progress
+check :: HasCard a => IO Blog -> a -> (Text, Text, Maybe String, String, String) -> IO Progress
 check getBlog input (expectedCT, expectedD, expectedI, expectedT, expectedU) =
   getBlog >>= runReaderT (
       sequence [
@@ -35,14 +33,14 @@ articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
       ("simple article components", check Blog.simple Article.simple (
             "article"
           , "It's a test"
-          , Just (pathRelative "test.png")
+          , Just "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 (pathRelative "test.png")
+          , Just "test.png"
           , "Some test"
           , "articles/test.html"
         ))

test/XML/Card/Output.hs

@@ -2,17 +2,15 @@ module XML.Card.Output (
     test
   ) where
 
-import Blog (Blog(..), URLs(..))
+import Blog (Blog(..), URL(..))
 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, subPath)
+import Mock.Blog as Blog (noCards, simple)
-import Mock.Article as Article (
+import Mock.Article as Article (noDescription, noImage, simple)
-    hostRelativeImage, noDescription, noImage, remoteImage, simple
-  )
 import Mock.ArticlesList as ArticlesList (
     longMain, longTesting, shortMain, shortTesting
   )
@@ -33,15 +31,8 @@ check getBlog input expectedFile =
 articleCard :: Test 
 articleCard = tag "article" . testGroup "Article cards" $ simpleTest <$> [
       ("simple article output", check Blog.simple Article.simple "simple.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 description"
+    , ("article output without image", check Blog.simple Article.noImage "noImage.html")
-      , 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

@@ -1 +0,0 @@
-<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

@@ -1 +0,0 @@
-<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

@@ -1 +0,0 @@
-<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

@@ -1,27 +0,0 @@
-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))
-  ]