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,22 +50,21 @@ library
                      , Pretty
                      , RSS
   -- other-extensions:
-  build-depends:       aeson >= 1.2.0 && < 1.6
-                     , base >= 4.9.1 && < 4.16
+  build-depends:       aeson >= 1.2.0 && < 2.1
+                     , 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
-                     , lucid >= 2.8.0 && < 2.10
+                     , lucid >= 2.8.0 && < 2.12
                      , 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
@@ -76,7 +75,7 @@ executable hablo
   -- other-extensions:
   build-depends:       base
                      , hablo
-                     , mtl
+                     , mtl >= 2.2.2 && < 2.3
   ghc-options:         -Wall
   default-language:    Haskell2010
 
@@ -94,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
@@ -111,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 {full}) = if full then "." else "all.html"
+otherURL :: ArticlesList -> String
+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
-    , favicon :: Maybe URL
+    , cardImage :: Maybe FilePath
+    , 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 _ (Just path) = Just <$> checkURL path
+findImage :: String -> Maybe FilePath -> IO (Maybe FilePath)
+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(..)
-    , URLs(..)
+      URL(..)
     , 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 Data.Aeson (ToJSON(..), (.=), pairs)
+import GHC.Generics (Generic)
 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)]
-  }
+data URL = URL {
+      cards :: Maybe String
+    , comments :: Maybe String
+    , rss :: Maybe String
+  } deriving Generic
 
-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)
+instance ToJSON URL where
+  toEncoding (URL {comments}) = pairs (
+      "comments" .= 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 -> IO URL
 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)
+  cards <- getSiteURL argOGCards "Open Graph cards"
+  rss <- getSiteURL argRSS "RSS feeds"
   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
-    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
+    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 ()

src/DOM.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 module DOM (
-      PageType(..)
+      HasContent(..)
     , htmlDocument
   ) where
 
@@ -10,41 +10,36 @@ import qualified Article (preview)
 import ArticlesList (
     ArticlesList(..), description, getArticles, otherURL, rssLinkTexts
   )
-import Blog (Blog(..), Skin(..), URLs(..), template)
-import Blog.URL (localPrefix)
-import qualified Collection (tag)
+import Blog (Blog(..), Skin(..), URL(..), template)
 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 Markdown (Markdown(..), MarkdownContent(..))
-import Network.URL (URL)
 import Page (Page)
 import Prelude hiding (head, lookup)
 import Pretty ((.$))
-import System.FilePath.Posix ((</>), (<.>))
+import System.FilePath.Posix ((<.>))
 
 type HtmlGenerator = HtmlT (ReaderT Blog IO)
 
-class HasCard a => PageType a where
+class HasCard a => HasContent a where
   content :: a -> HtmlGenerator ()
-  pathToRoot :: a -> FilePath
 
-instance PageType Article where
-  content = mDContent True ".." . getMarkdown
-  pathToRoot _ = ".."
+instance HasContent Article where
+  content = mDContent True . getMarkdown
 
-instance PageType Page where
-  content = mDContent True ".." . getMarkdown
-  pathToRoot _ = ".."
+instance HasContent Page where
+  content = mDContent True . getMarkdown
 
-instance PageType ArticlesList where
+instance HasContent ArticlesList where
   content al@(ArticlesList {full}) = do
     preview <- Article.preview <$> (asks $skin.$previewLinesCount)
     h2_ . toHtml =<< description al
@@ -52,7 +47,7 @@ instance PageType ArticlesList where
       asks hasRSS >>= rssLink
       li_ . a_ [href_ . pack $ otherURL al, class_ "other"] =<< otherLink
     div_ [class_ "articles"] (
-        mapM_ (mDContent False (pathToRoot al) . preview) =<< getArticles al
+        mapM_ (mDContent False . preview) =<< getArticles al
       )
     where
       otherLink =
@@ -63,38 +58,34 @@ instance PageType ArticlesList where
         li_ . a_ [href_ "rss.xml", class_ "RSS", title_ title] $ toHtml text
       rssLink False = return ()
 
-  pathToRoot = maybe "." (\_ -> "..") . Collection.tag . collection
-
-mDContent :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
-mDContent raw base markdown@(Markdown {key, body}) =
+mDContent :: Bool -> Markdown -> HtmlGenerator ()
+mDContent raw markdown@(Markdown {key, body}) =
   article_ [id_ $ pack key] (do
-      header_ . h1_ $ mDLink raw base markdown
+      header_ . h1_ $ mDLink raw markdown
       pre_ . toHtml $ unlines body
     )
 
-mDLink :: Bool -> FilePath -> Markdown -> HtmlGenerator ()
-mDLink raw base (Markdown {Markdown.path, title}) = link $ toHtml title
+mDLink :: Bool -> Markdown -> HtmlGenerator ()
+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
-prefix base = pack . (base </>)
+tag :: String -> HtmlGenerator ()
+tag name =
+  a_ [href_ . pack $ absoluteLink name ++ "/", class_ "tag"] $ toHtml name
 
-tag :: FilePath -> String -> HtmlGenerator ()
-tag base name =
-  a_ [href_ . prefix base $ name ++ "/", class_ "tag"] $ toHtml name
-
-defaultBanner :: FilePath -> HtmlGenerator ()
-defaultBanner base =
+defaultBanner :: HtmlGenerator ()
+defaultBanner =
   div_ [id_ "header"] (
-      a_ [href_ $ pack base] (
+      a_ [href_ "/"] (
           h1_ . toHtml =<< asks name
         )
     )
 
-faviconLink :: FilePath -> URL -> HtmlGenerator ()
-faviconLink base url = link_ [
-    rel_ "shortcut icon", href_ $ localPrefix base url, type_ "image/x-icon"
+faviconLink :: FilePath -> HtmlGenerator ()
+faviconLink url = link_ [
+    rel_ "shortcut icon", href_ . pack $ absoluteLink url, type_ "image/x-icon"
   ]
 
 optional :: (a -> HtmlGenerator ()) -> Maybe a -> HtmlGenerator ()
@@ -110,25 +101,24 @@ navigationSection sectionId templateKey generator collection
           ul_ . mapM_  (li_ . generator) $ Map.toList collection
         )
 
-htmlDocument :: PageType a => a -> HtmlGenerator ()
+htmlDocument :: HasContent a => a -> HtmlGenerator ()
 htmlDocument someContent =
-  let base = pathToRoot someContent in
   doctypehtml_ (do
       head_ (do
           meta_ [charset_ "utf-8"]
           title_ . toHtml =<< asks name
-          script_ [src_ $ prefix base "js/remarkable.min.js"] empty
-          script_ [src_ $ prefix base "js/hablo.js"] empty
-          optional (faviconLink base) =<< (asks $skin.$favicon)
+          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 base) toHtmlRaw =<< (asks $skin.$banner)
+          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
         )
     )

src/DOM/Card.hs

@@ -10,7 +10,6 @@ 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 ((<|>))
@@ -20,7 +19,6 @@ import Data.Text (Text, pack)
 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 ((.$))
@@ -29,7 +27,7 @@ import System.FilePath.Posix ((</>), (<.>))
 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
 
@@ -40,19 +38,20 @@ og attribute value =
       , content_ value
     ]
 
-make :: (HasCard a, Renderer m) => a -> AbsoluteURL -> HtmlT m ()
+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 ()) (og "image" . defaultOn siteURL)
+    maybeImage = maybe (return ()) (og "image" . sitePrefix)
+    sitePrefix = pack . (siteURL </>)
 
-mDImage :: (Renderer m, MarkdownContent a) => a -> m (Maybe URL)
-mDImage = mapM checkURL . Map.lookup "featuredImage" . metadata . getMarkdown
+mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String)
+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]
-  maybe (die "JS compilation failed\n") output =<< sourceCode result
+  compile (source [destinationDir, "unitJS", habloSources])
+    >>= 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,13 +7,12 @@ module RSS (
 
 import Article (Article(..))
 import ArticlesList (ArticlesList(..), getArticles)
-import qualified ArticlesList (description, path)
-import Blog (Blog(urls), Renderer, URLs(..))
-import Blog.URL (AbsoluteURL, pathOn)
+import qualified ArticlesList (description)
+import Blog (Blog(urls), Renderer, URL(..))
 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)
@@ -58,24 +57,24 @@ item_ = term "item"
 pubDate_ :: Term arg result => arg -> result
 pubDate_ = term "pubDate"
 
-articleItem :: Monad m => AbsoluteURL -> Article -> HtmlT m ()
+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 -> HtmlT m ()
+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
@@ -83,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 Mock.URL (prefixedTestSite, testSite)
+import Blog.URL (URL(..))
 
-simple :: URLs
-simple = URLs {
-      cards = Just testSite
+simple :: URL
+simple = URL {
+      cards = Just "https://test.net"
     , comments = Nothing
     , rss = Nothing
   }
 
-subPath :: URLs
-subPath = URLs {
-      cards = Just prefixedTestSite
-    , comments = Nothing
-    , rss = Nothing
-  }
-
-noCards :: URLs
+noCards :: URL
 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.Article as Article (
-    hostRelativeImage, noDescription, noImage, remoteImage, simple
-  )
+import Mock.Blog as Blog (noCards, simple)
+import Mock.Article as Article (noDescription, noImage, 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 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")
+    , ("article output without description", check Blog.simple Article.noDescription "noDescription.html")
+    , ("article output without image", check Blog.simple Article.noImage "noImage.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))
-  ]