.gitignore

@@ -1,7 +1,6 @@
 dist*
 static/tmp/
 static/combined/
-static/uploads/
 config/client_session_key.aes
 *.hi
 *.o

config/models

@@ -4,7 +4,7 @@ User
     fullName Text maxlen=500
     email Text maxlen=190
     avatar Text maxlen=190
-    note Markdown sqltype=mediumtext
+    note Text sqltype=mediumtext
     UniqueUser username
     UniqueEmail email
     deriving Typeable
@@ -26,10 +26,10 @@ Profile
     displayName Text Maybe sqltype=varchar(255)
 
 Entry
-    kind EntryKind maxlen=255
+    slug Slug
-    name Text Maybe maxlen=255
+    kind EntryKind
-    content Markdown sqltype=longtext
+    name Text maxlen=255
-    photo Text Maybe maxlen=190
+    content Text sqltype=longtext
     published UTCTime
     updated UTCTime
     authorId UserId
@@ -38,8 +38,3 @@ Syndication
     entryId EntryId
     profileId ProfileId
     url Text sqltype=varchar(255)
-
-EntryCategory
-    entryId EntryId
-    category Category sqltype=varchar(190)
-    UniqueEntryCategory entryId category

config/routes

@@ -7,12 +7,9 @@
 /sitemap.xml SitemapR GET
 
 / HomeR GET
-/avatars/#UserId AvatarR GET
-/categories/#Category CategoryR GET
-
 /feed FeedR GET
 !/#EntryKind/feed FeedKindR GET
 
 !/#EntryKind EntriesR GET
-!/#EntryKind/#EntryId EntryR GET
+!/#EntryKind/#EntryId EntryNoSlugR GET
-!/#EntryKind/#EntryId/#Slug EntryWithSlugR GET
+!/#EntryKind/#EntryId/#Slug EntryR GET

config/settings.yml

@@ -33,6 +33,5 @@ database:
 
 title: 00dani.me
 app-name: lebd
-username: dani
 repository: https://gitlab.com/00dani/lebd
-fb-app-id: "_env:FB_APP_ID:142105433189339"
+#analytics: UA-YOURCODE

lebd.svg

@@ -1,6 +0,0 @@
-<?xml version="1.0" encoding="UTF-8"?>
-<svg width="200" height="200" version="1.1" xmlns="http://www.w3.org/2000/svg">
-    <title>lebd</title>
-    <circle id="bg" fill="#343A40" cx="100" cy="100" r="100"></circle>
-    <text id="l" font-family="Arial Unicode MS" font-size="190" fill="#00A6F9" x="15" y="160">ℒ</text>
-</svg>

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "lebd",
-  "version": "1.6.4",
+  "version": "1.4.4",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "lebd",
-  "version": "1.6.4",
+  "version": "1.4.4",
   "description": "the codebase backing 00dani.me, an indieweb.org site",
   "repository": {
     "type": "git",

package.yaml

@@ -1,5 +1,5 @@
 name:    lebd
-version: "1.6.4"
+version: "1.4.4"
 
 dependencies:
 
@@ -52,7 +52,6 @@ dependencies:
 - esqueleto >=2.5 && <2.6
 - friendly-time >=0.4 && <0.5
 - foreign-store >=0.2 && <0.3
-- markdown >=0.1 && <0.2
 - mustache >=2.2 && <2.3
 - parsec >=3.1 && <3.2
 - slug >=0.1 && <0.2

src/Application.hs

@@ -48,9 +48,7 @@ import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
-import Handler.Avatars
 import Handler.Common
-import Handler.Categories
 import Handler.Entries
 import Handler.Feed
 import Handler.Home

src/Entry/Kind.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
-module Model.Entry.Kind where
+module Entry.Kind where
 
 import Database.Persist.TH ( derivePersistField )
 import Yesod.Core.Dispatch ( PathPiece, toPathPiece, fromPathPiece )

src/Foundation.hs

@@ -21,13 +21,9 @@ import Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
 
 import Package
-import Model.Cache ( getCached )
+import Entry.Kind ( EntryKind, allEntryKinds, pluralise )
-import Model.Category ( Category )
-import Model.Entry ( entryTitle )
-import Model.Entry.Kind ( EntryKind, allEntryKinds, pluralise )
-import SchemaOrg.BreadcrumbList ( breadcrumbList )
 
-import Data.Aeson ( encode )
+import Data.Aeson ( encode, object )
 import qualified Text.Blaze.Internal as B
 import qualified Data.Text as T
 import qualified Data.Text.Lazy.Encoding as E
@@ -67,9 +63,6 @@ mkYesodData "App" $(parseRoutesFile "config/routes")
 -- | A convenient synonym for creating forms.
 type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
 
-sessionLifetime :: Int
-sessionLifetime = 120 -- minutes
-
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
 instance Yesod App where
@@ -80,7 +73,7 @@ instance Yesod App where
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
     makeSessionBackend _ = sslOnlySessions . strictSameSiteSessions $ Just <$> defaultClientSessionBackend
-        sessionLifetime
+        120    -- timeout in minutes
         "config/client_session_key.aes"
 
     -- Redirect static requests to a subdomain - this is recommended for best
@@ -100,7 +93,7 @@ instance Yesod App where
     --   b) Validates that incoming write requests include that token in either a header or POST parameter.
     -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
     -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
-    yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware . sslOnlyMiddleware sessionLifetime
+    yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
 
     defaultLayout widget = do
         master <- getYesod
@@ -112,7 +105,7 @@ instance Yesod App where
         -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
         (title, crumbs) <- breadcrumbs
         let allCrumbs = maybe crumbs (\route -> crumbs ++ [(route, title)]) mcurrentRoute
-        jsonCrumbs <- fmap (E.decodeUtf8 . encode) . withUrlRenderer $ breadcrumbList allCrumbs
+        jsonCrumbs <- fmap (E.decodeUtf8 . encode) . withUrlRenderer $ jsonLdBreadcrumbList allCrumbs
 
         let navbars = [leftMenuItems, rightMenuItems] <*> [muser]
 
@@ -123,9 +116,7 @@ instance Yesod App where
         -- you to use normal widget features in default-layout.
 
         pc <- widgetToPageContent $(widgetFile "default-layout")
-        let globalTitle = toHtml . siteTitle . appSettings $ master
+        let hasPageTitle = not . B.null . pageTitle $ pc
-            hasPageTitle = not . B.null $ pageTitle pc
-            fullTitle = if hasPageTitle then mconcat [pageTitle pc, " ~ ", globalTitle] else globalTitle
         withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
 
     -- The page to be redirected to when authentication is required.
@@ -185,12 +176,27 @@ rightMenuItems = loggedOutItems `maybe` loggedInItems
 instance YesodBreadcrumbs App where
   breadcrumb (AuthR _) = return ("log in", Just HomeR)
   breadcrumb (EntriesR kind) = return (pluralise kind, Just HomeR)
-  breadcrumb (EntryR kind entryId) = do
+  breadcrumb (EntryR kind entryId _) = do
-    (Entity _ entry) <- getCached entryId
+    entry <- runDB . get404 $ entryId
-    return (entryTitle entry, Just $ EntriesR kind)
+    return (entryName entry, Just $ EntriesR kind)
-  breadcrumb (EntryWithSlugR kind entryId _) = breadcrumb $ EntryR kind entryId
   breadcrumb _ = return ("home", Nothing)
 
+jsonLdBreadcrumbList :: [(Route App, Text)] -> (Route App -> [(Text, Text)] -> Text) -> Value
+jsonLdBreadcrumbList crumbs url = object
+  [ ("@context", "http://schema.org")
+  , ("@type", "BreadcrumbList")
+  , "itemListElement" .= zipWith (jsonLdListItem url) [1 :: Int ..] crumbs
+  ]
+jsonLdListItem :: (Route App -> [(Text, Text)] -> Text) -> Int -> (Route App, Text) -> Value
+jsonLdListItem url i (r, t) = object
+  [ ("@type", "ListItem")
+  , "position" .= i
+  , "item" .= object
+    [ "@id" .= url r []
+    , "name" .= t
+    ]
+  ]
+
 -- How to run database actions.
 instance YesodPersist App where
     type YesodPersistBackend App = SqlBackend
@@ -253,7 +259,3 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 -- https://github.com/yesodweb/yesod/wiki/Sending-email
 -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
 -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
-userProfile :: User -> Route App
-userProfile user
-  | userUsername user == siteUsername compileTimeAppSettings = HomeR
-  | otherwise = error "Multiple profile pages are not yet supported"

src/Handler/Avatars.hs

@@ -1,17 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Handler.Avatars where
-
-import Import hiding ( (==.) )
-
-import Database.Esqueleto
-import Settings.StaticR ( staticR ) 
-
-getAvatarR :: UserId -> Handler ()
-getAvatarR = responseFrom <=< runDB . select . from . queryAvatar
-    where responseFrom (a:_) = redirect $ staticR ["img", unValue a]
-          responseFrom    [] = notFound
-          queryAvatar userId user = do
-              where_ $ user ^. UserId ==. val userId
-              return $ user ^. UserAvatar

src/Handler/Categories.hs

@@ -1,22 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Handler.Categories where
-
-import Import hiding ( on, (==.) )
-
-import Database.Esqueleto
-import Widget.Feed ( hFeed )
-import Model.Category ( Category, asTag )
-
-import qualified Data.Text as T
-
-getCategoryR :: Category -> Handler Html
-getCategoryR tag = do
-    title <- asks $ siteTitle . appSettings
-    entries <- runDB . select . from $ \(entry `InnerJoin` category) -> do
-        on $ entry ^. EntryId ==. category ^. EntryCategoryEntryId
-        where_ $ category ^. EntryCategoryCategory ==. val tag
-        return entry
-    defaultLayout $ do
-        setTitle . toHtml . asTag $ tag
-        T.concat [asTag tag, " ~ ", title] `hFeed` entries

src/Handler/Common.hs

@@ -7,13 +7,11 @@
 module Handler.Common where
 
 import Data.FileEmbed (embedFile)
-import Database.Esqueleto ( (^.) )
-import qualified Database.Esqueleto as E
 import Yesod.Sitemap
 
 import Import
 
-import Model.Entry.Kind ( allEntryKinds )
+import Entry.Kind ( EntryKind, allEntryKinds )
 import Widget.Entry ( entryR )
 
 -- These handlers embed files in the executable at compile time to avoid a
@@ -33,9 +31,6 @@ getRobotsR = robots SitemapR
 
 getSitemapR :: Handler TypedContent
 getSitemapR = do
-    categories <- runDB . E.select . E.distinct . E.from $ \ec -> do
-        E.orderBy [E.asc $ ec ^. EntryCategoryCategory]
-        return $ ec ^. EntryCategoryCategory
     entries <- runDB $ selectList [] [Desc EntryPublished]
     sitemap $ do
         yield SitemapUrl
@@ -44,19 +39,20 @@ getSitemapR = do
             , sitemapChangeFreq = Just Daily
             , sitemapPriority = Nothing
             }
-        yieldMany $ sitemapUrl . CategoryR . E.unValue <$> categories
+        yieldMany $ kindToSitemapUrl <$> allEntryKinds
-        yieldMany $ sitemapUrl . EntriesR <$> allEntryKinds
         yieldMany $ entryToSitemapUrl <$> entries
 
-sitemapUrl :: a -> SitemapUrl a
+kindToSitemapUrl :: EntryKind -> SitemapUrl (Route App)
-sitemapUrl loc = SitemapUrl
+kindToSitemapUrl kind = SitemapUrl
-    { sitemapLoc = loc
+    { sitemapLoc = EntriesR kind
     , sitemapLastMod = Nothing
     , sitemapChangeFreq = Nothing
     , sitemapPriority = Nothing
     }
-
 entryToSitemapUrl :: Entity Entry -> SitemapUrl (Route App)
-entryToSitemapUrl entry = (sitemapUrl $ entryR entry)
+entryToSitemapUrl entry = SitemapUrl
-    { sitemapLastMod = Just . entryUpdated . entityVal $ entry
+    { sitemapLoc = entryR entry
+    , sitemapLastMod = Just . entryUpdated . entityVal $ entry
+    , sitemapChangeFreq = Nothing
+    , sitemapPriority = Nothing
     }

src/Handler/Entries.hs

@@ -1,54 +1,40 @@
 {-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Handler.Entries where
 
 import Import
 
+import Web.Slug ( Slug )
 import Yesod.AtomFeed ( atomLink )
+import qualified Data.Text as T
 
-import Model.Cache ( getCached )
+import qualified Entry.Kind as K
-import Model.Entry ( entryTitle )
-import Model.Markdown ( unMarkdown )
 import Widget.Entry ( entryR, hEntry )
 import Widget.Feed ( hFeed )
 
-import qualified Data.Text as T
-import qualified Model.Entry.Kind as K
-
 getEntriesR :: K.EntryKind -> Handler Html
 getEntriesR kind = do
     entries <- runDB $ selectList [EntryKind ==. kind] [Desc EntryPublished]
     title <- asks $ siteTitle . appSettings
-    let myTitle = T.concat [K.pluralise kind, " ~ ", title]
     defaultLayout $ do
         setTitle . toHtml . K.pluralise $ kind
-        FeedKindR kind `atomLink` myTitle
+        atomLink (FeedKindR kind) $ T.concat [K.pluralise kind, " ~ ", title]
-        hFeed myTitle entries
+        $(widgetFile "entries")
 
-getEntryR :: a -> EntryId -> Handler Html
+checkMatching :: K.EntryKind -> Slug -> Entry -> Bool
-getEntryR _ = renderEntry <=< getCached
+checkMatching kind slug entry = (kind == entryKind entry) && (slug == entrySlug entry)
 
-getEntryWithSlugR :: a -> EntryId -> b -> Handler Html
+getEntryNoSlugR :: a -> EntryId -> Handler Html
-getEntryWithSlugR kind = const . getEntryR kind
+getEntryNoSlugR _ entryId = do
+    entry <- fmap (Entity entryId) . runDB . get404 $ entryId
+    redirectWith movedPermanently301 . entryR $ entry
 
-renderEntry :: (Entity Entry) -> Handler Html
+getEntryR :: K.EntryKind -> EntryId -> Slug -> Handler Html
-renderEntry entry = do
+getEntryR kind entryId slug = do
-    let correctRoute = entryR entry
+    entry <- fmap (Entity entryId) . runDB . get404 $ entryId
-    actualRoute <- getCurrentRoute
+    if checkMatching kind slug $ entityVal entry
-    author <- getCached . entryAuthorId $ entityVal entry
+       then defaultLayout $ do
-    when (actualRoute /= Just correctRoute) $
+           setTitle . toHtml . entryName . entityVal $ entry
-        redirectWith movedPermanently301 correctRoute
+           $(widgetFile "entry")
-    defaultLayout $ do
+       else redirectWith movedPermanently301 $ entryR entry
-        setTitle . toHtml . entryTitle . entityVal $ entry
-        toWidgetHead [hamlet|
-            <meta name="author" content=#{userFullName $ entityVal author}>
-            <link rel="author" href=@{userProfile $ entityVal author}>
-            <meta name="description" content=#{unMarkdown $ entryContent $ entityVal entry}>
-            <meta property="og:title" content=#{entryTitle $ entityVal entry}>
-            <meta property="og:type" content="article">
-            <meta property="og:description" content=#{unMarkdown $ entryContent $ entityVal entry}>
-            <meta property="article:author" content=@{userProfile $ entityVal author}>
-            <meta property="article:section" content=#{K.pluralise $ entryKind $ entityVal entry}>
-            |]
-        hEntry entry

src/Handler/Feed.hs

@@ -5,11 +5,10 @@ module Handler.Feed where
 import Import
 
 import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
-import Model.Entry ( entryTitle )
 import Widget.Entry ( entryR )
 
 import qualified Data.Text as T
-import qualified Model.Entry.Kind as K
+import qualified Entry.Kind as K
 
 getFeedR :: Handler TypedContent
 getFeedR = do
@@ -48,7 +47,7 @@ toFeedEntry :: Entity Entry -> FeedEntry (Route App)
 toFeedEntry entry = FeedEntry
     { feedEntryLink = entryR entry
     , feedEntryUpdated = entryUpdated $ entityVal entry
-    , feedEntryTitle = entryTitle $ entityVal entry
+    , feedEntryTitle = entryName $ entityVal entry
     , feedEntryContent = toHtml . entryContent . entityVal $ entry
     , feedEntryEnclosure = Nothing
     }

src/Handler/Home.hs

@@ -14,10 +14,14 @@ import Widget.Feed ( hFeed )
 
 getHomeR :: Handler Html
 getHomeR = do
-    settings <- asks appSettings
+    userE@(Entity userId user) <- runDB . getBy404 $ UniqueUser "dani"
-    user <- runDB . getBy404 . UniqueUser . siteUsername $ settings
+    title <- asks $ siteTitle . appSettings
-    let title = siteTitle settings
+    entries <- runDB $ selectList [EntryAuthorId ==. userId] [Desc EntryPublished]
-    entries <- runDB $ selectList [EntryAuthorId ==. entityKey user] [Desc EntryPublished]
     defaultLayout $ do
         atomLink FeedR title
+        toWidgetHead
+            [hamlet|
+                <meta name="author" content=#{userFullName user}>
+                <link rel="author" href=@{HomeR}>
+            |]
         $(widgetFile "home")

src/Model.hs

@@ -12,12 +12,11 @@ module Model where
 import ClassyPrelude.Yesod
 import Database.Persist.Quasi
 import Yesod.Auth.HashDB ( HashDBUser(..) )
+import Web.Slug ( Slug )
 import Text.Mustache ( (~>) )
 import qualified Text.Mustache as M
 
-import Model.Category ( Category )
+import Entry.Kind ( EntryKind )
-import Model.Entry.Kind ( EntryKind )
-import Model.Markdown ( Markdown )
 
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities

src/Model/Cache.hs

@@ -1,23 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-module Model.Cache ( getCached ) where
-
-import Data.Typeable ( Typeable )
-import Database.Persist ( Entity (..), Key (..), PersistStore, PersistRecordBackend, keyToValues )
-import Yesod ( MonadHandler, HandlerSite, YesodPersist, YesodPersistBackend, cachedBy, get404, liftHandlerT, runDB )
-
-import qualified Data.ByteString.Char8 as C
-
-newtype CachedEntity t = CachedEntity { unCachedEntity :: Entity t } deriving Typeable
-
-getCached :: ( MonadHandler m
-             , YesodPersist (HandlerSite m)
-             , PersistStore (YesodPersistBackend (HandlerSite m))
-             , PersistRecordBackend entity (YesodPersistBackend (HandlerSite m))
-             , Typeable entity
-             ) => Key entity -> m (Entity entity)
-getCached entId = liftHandlerT . cached . runDB . withId . get404 $ entId
-    where key = C.pack . show . keyToValues $ entId
-          withId = fmap $ Entity entId
-          cached = fmap unCachedEntity . cachedBy key . fmap CachedEntity

src/Model/Category.hs

@@ -1,14 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Model.Category where
-
-import Database.Persist ( PersistField )
-import Web.Slug ( Slug, unSlug )
-import Yesod ( PathPiece )
-
-import qualified Data.Text as T
-
-newtype Category = Category { unCategory :: Slug }
-    deriving (Eq, Read, Show, PathPiece, PersistField)
-
-asTag :: Category -> T.Text
-asTag = T.cons '#' . unSlug . unCategory

src/Model/Entry.hs

@@ -1,30 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Model.Entry where
-
-import Model ( Entry, entryName, entryContent )
-import Model.Markdown ( Markdown(Markdown), unMarkdown )
-import Data.Maybe ( fromMaybe )
-
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-
-entryTitle :: Entry -> T.Text
-entryTitle = fromMaybe <$> TL.toStrict . unMarkdown . shorten 30 . entryContent <*> entryName
-
-class Shorten a where
-  shorten :: Int -> a -> a
-
-instance Shorten T.Text where
-  shorten i t
-    | T.compareLength t n == GT = flip T.append "..." . T.take (n - 1) $ t
-    | otherwise                 = t
-    where n = fromIntegral i
-
-instance Shorten TL.Text where
-  shorten i t
-    | TL.compareLength t n == GT = flip TL.append "..." . TL.take (n - 1) $ t
-    | otherwise                  = t
-    where n = fromIntegral i
-
-instance Shorten Markdown where
-  shorten n (Markdown t) = Markdown $ shorten n t

src/Model/Markdown.hs

@@ -1,38 +0,0 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Model.Markdown ( Markdown(..) ) where
-
-import Data.Aeson ( FromJSON(..), ToJSON(..), Value(Object), object, (.=), (.:) )
-import Data.Default ( def )
-import Database.Persist ( PersistField(..), PersistValue(PersistText) )
-import Database.Persist.Sql ( PersistFieldSql(..), SqlType(SqlString) )
-import Data.String ( IsString )
-import Text.Blaze ( ToMarkup(..) )
-import Text.Markdown ( markdown )
-
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-
-newtype Markdown = Markdown { unMarkdown :: TL.Text }
-    deriving (Eq, Ord, Monoid, IsString, Show)
-
-instance ToMarkup Markdown where
-    toMarkup (Markdown t) = markdown def t
-
-instance PersistField Markdown where
-    toPersistValue (Markdown t) = PersistText $ TL.toStrict t
-    fromPersistValue (PersistText t) = Right . Markdown $ TL.fromStrict t
-    fromPersistValue wrongValue = Left $ T.concat
-        [ "Model.Markdown: When attempting to create Markdown from a PersistValue, received "
-        , T.pack $ show wrongValue
-        , " when a value of type PersistText was expected."
-        ]
-instance PersistFieldSql Markdown where
-    sqlType _ = SqlString
-
-instance ToJSON Markdown where
-    toJSON (Markdown text) = object ["markdown" .= text]
-
-instance FromJSON Markdown where
-    parseJSON (Object v) = Markdown <$> v .: "markdown"
-    parseJSON _ = mempty

src/SchemaOrg/BreadcrumbList.hs

@@ -1,21 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module SchemaOrg.BreadcrumbList ( breadcrumbList ) where
-
-import Data.Aeson
-import qualified Data.Text as T
-
-breadcrumbList :: [(a, T.Text)] -> (a -> [(T.Text, T.Text)] -> T.Text) -> Value
-breadcrumbList crumbs url = object
-  [ ("@context", "http://schema.org")
-  , ("@type", "BreadcrumbList")
-  , "itemListElement" .= zipWith (listItem url) [1 :: Int ..] crumbs
-  ]
-listItem :: (a -> [(T.Text, T.Text)] -> T.Text) -> Int -> (a, T.Text) -> Value
-listItem url i (r, t) = object
-  [ ("@type", "ListItem")
-  , "position" .= i
-  , "item" .= object
-    [ "@id" .= url r []
-    , "name" .= t
-    ]
-  ]

src/Settings.hs

@@ -19,8 +19,9 @@ import Data.Yaml                  (decodeEither')
 import Database.Persist.MySQL     (MySQLConf (..))
 import Language.Haskell.TH.Syntax (Exp, Name, Q)
 import Network.Wai.Handler.Warp   (HostPreference)
+import Text.Hamlet                (HamletSettings(hamletNewlines), NewlineStyle(AlwaysNewlines), defaultHamletSettings)
 import Yesod.Default.Config2      (applyEnvValue, configSettingsYml)
-import Yesod.Default.Util         (WidgetFileSettings, widgetFileNoReload,
+import Yesod.Default.Util         (WidgetFileSettings(wfsHamletSettings), widgetFileNoReload,
                                    widgetFileReload)
 import qualified Database.MySQL.Base as MySQL
 
@@ -58,14 +59,11 @@ data AppSettings = AppSettings
     , appSkipCombining          :: Bool
     -- ^ Perform no stylesheet/script combining
 
-    , appFacebookId          :: Maybe Int
+    -- Example app-specific configuration values.
-    -- ^ Facebook app ID.
+    , appAnalytics              :: Maybe Text
-
+    -- ^ Google Analytics code
     , siteTitle                 :: Text
     -- ^ Site-wide title.
-    , siteUsername              :: Text
-    -- ^ Username of the site's main user, whose h-card will appear on the
-    -- homepage.
 
     , appAuthDummyLogin         :: Bool
     -- ^ Indicate if auth dummy login should be enabled.
@@ -94,9 +92,8 @@ instance FromJSON AppSettings where
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
 
-        appFacebookId             <- o .:? "fb-app-id"
+        appAnalytics              <- o .:? "analytics"
         siteTitle                 <- o .: "title"
-        siteUsername              <- o .: "username"
 
         -- This code enables MySQL's strict mode, without which MySQL will truncate data.
         -- See https://github.com/yesodweb/persistent/wiki/Database-Configuration#strict-mode for details
@@ -119,7 +116,7 @@ instance FromJSON AppSettings where
 --
 -- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
 widgetFileSettings :: WidgetFileSettings
-widgetFileSettings = def
+widgetFileSettings = def { wfsHamletSettings = defaultHamletSettings { hamletNewlines = AlwaysNewlines } }
 
 -- | How static files should be combined.
 combineSettings :: CombineSettings

src/Site.hs

@@ -0,0 +1,21 @@
+module Site ( fetch ) where
+
+import Foundation ( Handler )
+import Model
+import Util ( compileMustache, entityToTuple )
+
+import Text.Mustache ( Template )
+import Yesod ( Key, runDB, selectList, (<-.) )
+
+import qualified Data.Map as M
+import qualified Data.Text as T
+
+compileTemplates :: M.Map (Key Site) Site -> M.Map (Key Site) (Site, Template)
+compileTemplates = fmap $ \site -> (site, compile site)
+    where compile site = T.unpack (siteIcon site) `compileMustache` siteTemplate site
+
+fetch :: [Key Site] -> Handler (M.Map (Key Site) (Site, Template))
+fetch = fmap compileTemplates . fetchSites
+
+fetchSites :: [SiteId] -> Handler (M.Map (Key Site) Site)
+fetchSites siteIds = runDB $ M.fromList . map entityToTuple <$> selectList [SiteId <-. siteIds] []

src/Widget/Card.hs

@@ -1,56 +1,35 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Widget.Card ( hCard ) where
 
 import Import
 
-import Database.Esqueleto ( (^.) )
+import qualified Site
-import qualified Database.Esqueleto as E
-
-import Model.Markdown ( unMarkdown )
-import Text.Mustache ( substitute )
-import Util ( compileMustache )
 
+import Data.Maybe (fromJust)
+import Text.Mustache ( Template, substitute )
+import qualified Data.Map as M
 import qualified Data.Text as T
 
+arrangeProfiles :: [Profile] -> M.Map (Key Site) (Site, Template) -> [((Site, Template), Profile)]
+arrangeProfiles profiles sites = sortBy icon $ zip profileSites profiles
+    where findSite = fromJust . flip M.lookup sites . profileSiteId
+          profileSites = findSite <$> profiles
+          icon = comparing $ siteName . fst . fst
+
 prettyPgp :: PgpKey -> Text
 prettyPgp = T.unwords . T.chunksOf 4 . pgpKeyFingerprint
 
 routeFromPgp :: PgpKey -> Route App
 routeFromPgp PgpKey { pgpKeyFingerprint = f } = staticR ["pgp", T.takeEnd 8 f ++ ".asc"]
 
-profileUrl :: Site -> Profile -> Text
-profileUrl site = substitute $ T.unpack (siteName site) `compileMustache` siteTemplate site
-
 hCard :: Entity User -> Widget
 hCard (Entity userId user) = do
-    let (firstName:lastName) = T.words $ userFullName user
     mcurrentRoute <- getCurrentRoute
-    userProfiles <- handlerToWidget . runDB . E.select . E.from $ \(profile `E.InnerJoin` site) -> do
+    userProfiles <- handlerToWidget $ do
-        E.on $ profile ^. ProfileSiteId E.==. site ^. SiteId
+        profiles <- runDB $ map entityVal <$> selectList [ProfileUserId ==. userId] []
-        E.where_ $ profile ^. ProfileUserId E.==. E.val userId
+        sites <- Site.fetch $ profileSiteId <$> profiles
-        E.orderBy [E.asc $ site ^. SiteName]
+        return . arrangeProfiles profiles $ sites
-        return (site, profile)
     pgpKeys <- handlerToWidget . runDB $ map entityVal <$> selectList [PgpKeyUserId ==. userId] []
-    let maybeFb = find (\(Entity _ site, _) -> "Facebook" == siteName site) userProfiles
-
-    toWidgetHead [hamlet|
-        <meta name="author" content=#{userFullName user}>
-        <meta name="description" content=#{unMarkdown $ userNote user}>
-        <link rel="author" href=@{HomeR}>
-        <meta property="og:type" content="profile">
-        <meta property="og:title" content="#{userFullName user}">
-        <meta property="og:description" content=#{unMarkdown $ userNote user}>
-        <meta property="og:image" content=@{staticR ["img", userAvatar user]}>
-        <meta property="profile:first_name" content=#{firstName}>
-        <meta property="profile:last_name" content=#{T.unwords lastName}>
-        <meta property="profile:username" content=#{userUsername user}>
-        $maybe (_, Entity _ fb) <- maybeFb
-            <meta property="fb:profile_id" content=#{profileUsername fb}>
-        $forall key <- pgpKeys
-            <link rel="pgpkey" type="application/pgp-keys" href=@{routeFromPgp key}>
-    |]
-
     $(widgetFile "mf2/h-card")

src/Widget/Entry.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Widget.Entry ( entryR, hEntry ) where
 
@@ -10,8 +9,6 @@ import Database.Esqueleto ( (^.) )
 import qualified Database.Esqueleto as E
 import Data.Time.Format ( defaultTimeLocale, formatTime, iso8601DateFormat )
 import Data.Time.Format.Human ( humanReadableTime )
-import Model.Entry ( entryTitle )
-import Web.Slug ( mkSlug )
 
 data FormattedTime = FormattedTime
     { timeUnfriendly :: String
@@ -24,9 +21,7 @@ toFormattedTime time = FormattedTime (unfriendly time) <$> friendly time
           friendly = liftIO . humanReadableTime
 
 entryR :: Entity Entry -> Route App
-entryR (Entity entryId Entry {..}) = route (entryName >>= mkSlug) entryKind entryId
+entryR (Entity entryId entry) = EntryR (entryKind entry) entryId (entrySlug entry)
-    where route (Just s) = \k i -> EntryWithSlugR k i s
-          route Nothing  = EntryR
 
 hEntry :: Entity Entry -> Widget
 hEntry (Entity entryId entry) = do

src/Widget/Feed.hs

@@ -4,9 +4,5 @@ module Widget.Feed ( hFeed ) where
 import Import
 import Widget.Entry ( hEntry )
 
-import qualified Data.Text as T
+hFeed :: [Entity Entry] -> Widget
-
+hFeed entries = $(widgetFile "mf2/h-feed")
-hFeed :: T.Text -> [Entity Entry] -> Widget
-hFeed name entries = do
-    mroute <- getCurrentRoute
-    $(widgetFile "mf2/h-feed")

templates/default-layout-wrapper.hamlet

@@ -5,12 +5,12 @@ $doctype 5
     <meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">
     <meta name="generator" content="#{packageName package} #{packageVersion package}">
 
-    <title>#{fullTitle}
+    <title>
+      $if hasPageTitle
+        #{pageTitle pc} ~ #
+      #{siteTitle $ appSettings master}
     $maybe route <- mcurrentRoute
       <link rel="canonical" href=@{route}>
-      <meta property="og:url" content=@{route}>
-    $maybe fb <- appFacebookId $ appSettings master
-      <meta property="fb:app_id" content=#{fb}>
     <link rel="sitemap" href=@{SitemapR}>
 
     <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0-beta/css/bootstrap.min.css" integrity="sha384-/Y6pD6FV/Vv2HJnA6t+vslU6fwYXjCFtcEpHbNJ0lyAFsXTsjBbfaDjzALeQsN6M" crossorigin="anonymous">
@@ -25,3 +25,14 @@ $doctype 5
     <script src="https://code.jquery.com/jquery-3.2.1.slim.min.js" integrity="sha384-KJ3o2DKtIkvYIK3UENzmM7KCkRr/rE9/Qpg6aAZGJwFDMVNA/GpGFF93hXpG5KkN" crossorigin="anonymous">
     <script src="https://cdnjs.cloudflare.com/ajax/libs/popper.js/1.11.0/umd/popper.min.js" integrity="sha384-b/U6ypiBEHpOf/4+1nzFpr53nxSS+GLCkfwBdFNTxtclqqenISfwAzpKaMNFNmj4" crossorigin="anonymous">
     <script src="https://maxcdn.bootstrapcdn.com/bootstrap/4.0.0-beta/js/bootstrap.min.js" integrity="sha384-h0AbiXch4ZDo7tp9hKZ4TsHbi047NrKGLO3SEJAg45jXxnGIfYzk4Si90RDIqNm1" crossorigin="anonymous">
+    $maybe analytics <- appAnalytics $ appSettings master
+      <script>
+        if(!window.location.href.match(/localhost/)){
+            (function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){
+            (i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o),
+            m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m)
+            })(window,document,'script','https://www.google-analytics.com/analytics.js','ga');
+
+            ga('create', '#{analytics}', 'auto');
+            ga('send', 'pageview');
+        }

templates/default-layout.cassius

@@ -7,13 +7,6 @@ a
     text-decoration: none
     line-height: 1
 
-code, kbd, pre, samp
-  font-family: Monoid, Hack, Inconsolata, Menlo, Monaco, Consolas, "Liberation Mono", monospace
-code, pre
-  color: #cccccc
-code
-  background-color: #141414
-
 body
   background-color: #1d1f21
   color: #c9cacc

templates/default-layout.hamlet

@@ -1,5 +1,5 @@
 <header>
-    <nav .navbar .navbar-expand-md .navbar-dark.bg-dark>
+    <nav .navbar .navbar-expand-lg .navbar-dark.bg-dark>
         <a .navbar-brand rel="home" href=@{HomeR}>#{siteTitle $ appSettings master}
         <button type="button" .navbar-toggler data-toggle="collapse" data-target="#navbar" aria-expanded="false" aria-controls="navbar" aria-label="Toggle navigation">
             <span .navbar-toggler-icon>

templates/entries.hamlet

@@ -0,0 +1 @@
+^{hFeed entries}

templates/entry.hamlet

@@ -0,0 +1 @@
+^{hEntry entry}

templates/home.cassius

@@ -2,10 +2,11 @@ body > main
   display: flex
   flex-direction: column
   align-items: center
-  > div.h-feed
+  > ol.h-feed
     flex: 1
     margin-bottom: 0
-  > aside.author
+  > .author
+    height: 100%
     max-width: 25rem
     margin-bottom: 2em
     > .h-card
@@ -15,8 +16,8 @@ body > main
 @media (min-width: 768px)
   body > main
     flex-direction: row-reverse
-    align-items: unset
+    align-items: flex-start
-    > div.h-feed
+    > ol.h-feed
       margin-right: 2em
-    > aside.author
+    > .author
       margin-bottom: 0

templates/home.hamlet

@@ -1,2 +1,2 @@
-<aside .author>^{hCard user}
+<div .author>^{hCard userE}
-^{hFeed title entries}
+^{hFeed entries}

templates/mf2/h-card.hamlet

@@ -1,25 +1,26 @@
-<article .card.h-card .bg-dark itemscope itemtype="http://schema.org/Person">
+<div .card.h-card .bg-dark itemscope itemtype="http://schema.org/Person">
   $maybe route <- mcurrentRoute
     <a .u-uid.u-url itemprop="url" href=@{route} hidden>
 
-  <img .card-img-top.u-photo itemprop="image" src=@{AvatarR userId} alt=#{userFullName user}>
+  <img .card-img-top.u-photo itemprop="image" src=@{staticR ["img", userAvatar user]} alt="Avatar for #{userFullName user}">
 
   <div .card-body>
     <h4 .card-title.p-name itemprop="name">#{userFullName user}
     $forall key <- pgpKeys
-      <a .card-subtitle.u-key type="application/pgp-keys" href=@{routeFromPgp key}>
+      <a .card-subtitle.u-key href=@{routeFromPgp key}>
         <i .fa.fa-key>
         #{prettyPgp key}
-    <div .p-note itemprop="description" .text-muted>#{userNote user}
+        <link rel="pgpkey" type="application/pgp-keys" href=@{routeFromPgp key}>
+    <p .card-text.p-note .text-muted itemprop="description">#{userNote user}
 
     <ul .profiles>
       <li>
-        <a .u-email rel="me" itemprop="email" href="mailto:#{userEmail user}">
+        <a .u-email itemprop="email" rel="me" href="mailto:#{userEmail user}">
           <i .fa.fa-envelope>
           #{userEmail user}
-      $forall (Entity _ site, Entity _ profile) <- userProfiles
+      $forall ((site, template), profile) <- userProfiles
         <li>
-          <a .u-url rel="me" itemprop="sameAs" href="#{profileUrl site profile}">
+          <a .u-url itemprop="sameAs" rel="me" href="#{substitute template profile}">
             <i .#{siteIcon site}>
             $maybe name <- profileDisplayName profile
               #{name}

templates/mf2/h-entry.cassius

@@ -1,12 +1,7 @@
 article.h-entry
-  .e-content p:last-child
-    margin-bottom: 0
   > .card-footer
     display: flex
     flex-wrap: wrap
     justify-content: space-evenly
     > *
       margin-right: 1em
-    > .p-author img
-      height: 1em
-      vertical-align: -0.1em

templates/mf2/h-entry.hamlet

@@ -1,33 +1,20 @@
-<article .h-entry .card.bg-dark itemscope itemtype="http://schema.org/BlogPosting">
+<article .h-entry .card.bg-dark>
-  $maybe photo <- entryPhoto entry
-    <img .card-img-top.u-photo itemprop="image" src=@{staticR ["uploads", photo]} alt=#{entryTitle entry}>
   <div .card-body>
-    $maybe name <- entryName entry
+    <h4 .p-name .card-title>#{entryName entry}
-      <h4 .p-name .card-title itemprop="headline">#{name}
+    <div .e-content>
-      <div .e-content itemprop="articleBody">
-        #{entryContent entry}
-    $nothing
-      <div itemprop="headline" hidden>#{entryTitle entry}
-      <div .e-content.p-name itemprop="articleBody">
       #{entryContent entry}
   <div .card-footer>
     $maybe author <- maybeAuthor
-      <a .p-author.h-card href=@{userProfile author}>
+      <a .p-author.h-card href=@{HomeR}>
-        <img .u-photo src=@{AvatarR $ entryAuthorId entry} alt=#{userFullName author}>
+        <i .fa.fa-user>
         #{userFullName author}
-      $# Use a separate hidden block for the schema.org metadata because you
+    <a .u-url href="@{entryR (Entity entryId entry)}">
-      $# can't put itemprop="author" and itemprop="url" on the same element,
-      $# because schema.org is garbage.
-      <div hidden itemprop="author" itemscope itemtype="http://schema.org/Person">
-        <a itemprop="url" href=@{userProfile author}>
-          <span itemprop="name">#{userFullName author}
-    <a .u-url itemprop="mainEntityOfPage" href=@{entryR (Entity entryId entry)}>
       <i .fa.fa-link>
       permalink
-    <time .dt-published itemprop="datePublished" datetime=#{timeUnfriendly published} title=#{timeUnfriendly published}>
+    <time .dt-published datetime=#{timeUnfriendly published}>
       <i .fa.fa-calendar>
       #{timeFriendly published}
-    <time .dt-updated itemprop="dateModified" datetime=#{timeUnfriendly updated} title=#{timeUnfriendly updated} :published == updated:hidden>
+    <time .dt-updated datetime=#{timeUnfriendly updated} :published == updated:hidden>
       <i .fa.fa-pencil>
       #{timeFriendly updated}
     $forall (E.Value url, E.Value icon, E.Value name) <- posses

templates/mf2/h-feed.cassius

@@ -1,5 +1,5 @@
-div.h-feed
+ol.h-feed
-  > ol.list-unstyled
+  list-style: none
-    margin-bottom: 0
+  padding-left: 0
   > li:not(:last-child)
     margin-bottom: 1em

templates/mf2/h-feed.hamlet

@@ -1,7 +1,3 @@
-<div .h-feed>
+<ol .h-feed>
-  <span .p-name hidden>#{name}
-  $maybe route <- mroute
-    <a .u-url href=@{route} hidden>
-  <ol .list-unstyled>
   $forall entry <- entries
     <li>^{hEntry entry}