Add sslOnlyMiddleware to the Foundation

Different areas of the app need access to entities - for example both
the entry handler needs the entry itself to render it, but the
breadcrumbs also need the entry to decide what to label its breadcrumb.
Previously this was achieved by fetching entities from the database
twice. This sucks, so now it's implemented by fetching entities once and
caching them using Yesod's per-request cache.

.gitignore

@@ -1,6 +1,7 @@
 dist*
 static/tmp/
 static/combined/
+static/uploads/
 config/client_session_key.aes
 *.hi
 *.o
@@ -19,3 +20,4 @@ cabal.sandbox.config
 *~
 \#*
 lebd.cabal
+node_modules/

LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2017 Danielle McLean
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

config/models

@@ -1,23 +1,45 @@
 User
     username Text maxlen=190
+    password Text maxlen=79
     fullName Text maxlen=500
     email Text maxlen=190
-    note Text sqltype=mediumtext
-    UniqueUsername username
+    avatar Text maxlen=190
+    note Markdown sqltype=mediumtext
+    UniqueUser username
     UniqueEmail email
     deriving Typeable
 
 PgpKey
     userId UserId
     fingerprint Text maxlen=40
-    hash Text maxlen=64
     UniqueFingerprint fingerprint
 
 Site
+    name Text sqltype=varchar(255)
     icon Text sqltype=varchar(255)
-    url Text sqltype=varchar(255)
+    template Text sqltype=varchar(255)
 
 Profile
     userId UserId
     siteId SiteId
     username Text sqltype=varchar(255)
+    displayName Text Maybe sqltype=varchar(255)
+
+Entry
+    kind EntryKind maxlen=255
+    name Text Maybe maxlen=255
+    content Markdown sqltype=longtext
+    photo Text Maybe maxlen=190
+    published UTCTime
+    updated UTCTime
+    authorId UserId
+
+Syndication
+    entryId EntryId
+    profileId ProfileId
+    url Text sqltype=varchar(255)
+
+EntryCategory
+    entryId EntryId
+    category Category sqltype=varchar(190)
+    UniqueEntryCategory entryId category

config/routes

@@ -4,5 +4,15 @@
 /favicon.ico FaviconR GET
 /keybase.txt KeybaseR GET
 /robots.txt RobotsR GET
+/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/#Slug EntryWithSlugR GET

config/settings.yml

@@ -32,4 +32,7 @@ database:
   poolsize: "_env:MYSQL_POOLSIZE:10"
 
 title: 00dani.me
-#analytics: UA-YOURCODE
+app-name: lebd
+username: dani
+repository: https://gitlab.com/00dani/lebd
+fb-app-id: "_env:FB_APP_ID:142105433189339"

lebd.svg

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

@@ -0,0 +1,28 @@
+{
+  "name": "lebd",
+  "version": "1.6.4",
+  "lockfileVersion": 1,
+  "requires": true,
+  "dependencies": {
+    "docopt": {
+      "version": "0.6.2",
+      "resolved": "https://registry.npmjs.org/docopt/-/docopt-0.6.2.tgz",
+      "integrity": "sha1-so6eIiDaXsSffqW7JKR3h0Be6xE=",
+      "dev": true
+    },
+    "openwebicons": {
+      "version": "1.4.3",
+      "resolved": "https://registry.npmjs.org/openwebicons/-/openwebicons-1.4.3.tgz",
+      "integrity": "sha1-Bs7ri4K3Vqv+mQXhq+X/U/o0Z+k="
+    },
+    "sync-version": {
+      "version": "1.0.1",
+      "resolved": "https://registry.npmjs.org/sync-version/-/sync-version-1.0.1.tgz",
+      "integrity": "sha1-Y6aglKmigcUqgA1obqu5ZgH4igs=",
+      "dev": true,
+      "requires": {
+        "docopt": "0.6.2"
+      }
+    }
+  }
+}

package.json

@@ -0,0 +1,24 @@
+{
+  "name": "lebd",
+  "version": "1.6.4",
+  "description": "the codebase backing 00dani.me, an indieweb.org site",
+  "repository": {
+    "type": "git",
+    "url": "https://gitlab.com/00dani/lebd"
+  },
+  "author": "Danielle McLean <dani@00dani.me>",
+  "license": "MIT",
+  "bugs": {
+    "url": "https://gitlab.com/00dani/lebd/issues"
+  },
+  "homepage": "https://gitlab.com/00dani/lebd#README",
+  "devDependencies": {
+    "sync-version": "^1.0.1"
+  },
+  "scripts": {
+    "version": "sync-version package.yaml && git add ."
+  },
+  "dependencies": {
+    "openwebicons": "^1.4.3"
+  }
+}

package.yaml

@@ -1,5 +1,5 @@
 name:    lebd
-version: "1.1.0"
+version: "1.6.4"
 
 dependencies:
 
@@ -46,7 +46,21 @@ dependencies:
 - time
 - case-insensitive
 - wai
-- libravatar >=0.4 && <0.5
+
+- blaze-markup >=0.8 && <0.9
+- conduit-combinators >=1.1 && <1.2
+- 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
+- split >=0.2 && <0.3
+- unix >=2.7 && <2.8
+- yesod-auth-hashdb >=1.6.2 && <1.7
+- yesod-newsfeed >=1.6 && <1.7
+- yesod-sitemap >=1.4 && <1.5
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

src/Application.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Application
     ( getApplicationDev
@@ -47,7 +48,11 @@ 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
 
 -- This line actually creates our YesodDispatch instance. It is the second half

src/Foundation.hs

@@ -11,16 +11,27 @@ import Import.NoFoundation
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Text.Hamlet          (hamletFile)
 import Text.Jasmine         (minifym)
+import Web.Slug             (Slug)
 
--- Used only when in "auth-dummy-login" setting is enabled.
-import Yesod.Auth.Dummy
+import Yesod.Auth.HashDB    (authHashDBWithForm)
+import qualified Yesod.Auth.Message as AuthMsg
 
-import Yesod.Auth.OpenId    (authOpenId, IdentifierType (Claimed))
 import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Text.Encoding as TE
+
+import Package
+import Model.Cache ( getCached )
+import Model.Category ( Category )
+import Model.Entry ( entryTitle )
+import Model.Entry.Kind ( EntryKind, allEntryKinds, pluralise )
+import SchemaOrg.BreadcrumbList ( breadcrumbList )
+
+import Data.Aeson ( encode )
+import qualified Text.Blaze.Internal as B
+import qualified Data.Text as T
+import qualified Data.Text.Lazy.Encoding as E
+import qualified System.Posix.Files as F
 
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
@@ -37,13 +48,8 @@ data App = App
 data MenuItem = MenuItem
     { menuItemLabel :: Text
     , menuItemRoute :: Route App
-    , menuItemAccessCallback :: Bool
     }
 
-data MenuTypes
-    = NavbarLeft MenuItem
-    | NavbarRight MenuItem
-
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:
 -- http://www.yesodweb.com/book/routing-and-handlers
@@ -61,20 +67,20 @@ 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
     -- Controls the base of generated URLs. For more information on modifying,
     -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
-    approot = ApprootRequest $ \app req ->
-        case appRoot $ appSettings app of
-            Nothing -> getApprootText guessApproot app req
-            Just root -> root
+    approot = ApprootMaster $ fromMaybe "localhost" . appRoot . appSettings
 
     -- Store session data on the client in encrypted cookies,
     -- default session idle timeout is 120 minutes
     makeSessionBackend _ = sslOnlySessions . strictSameSiteSessions $ Just <$> defaultClientSessionBackend
-        120    -- timeout in minutes
+        sessionLifetime
         "config/client_session_key.aes"
 
     -- Redirect static requests to a subdomain - this is recommended for best
@@ -94,26 +100,21 @@ 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
+    yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware . sslOnlyMiddleware sessionLifetime
 
     defaultLayout widget = do
         master <- getYesod
         mmsg <- getMessage
 
-        -- muser <- maybeAuthPair
+        muser <- maybeAuthPair
         mcurrentRoute <- getCurrentRoute
 
         -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
-        (title, parents) <- breadcrumbs
+        (title, crumbs) <- breadcrumbs
+        let allCrumbs = maybe crumbs (\route -> crumbs ++ [(route, title)]) mcurrentRoute
+        jsonCrumbs <- fmap (E.decodeUtf8 . encode) . withUrlRenderer $ breadcrumbList allCrumbs
 
-        -- Define the menu items of the header.
-        let menuItems = []
-
-        let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems]
-        let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
-
-        let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x]
-        let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
+        let navbars = [leftMenuItems, rightMenuItems] <*> [muser]
 
         -- We break up the default layout into two components:
         -- default-layout is the contents of the body tag, and
@@ -122,18 +123,16 @@ instance Yesod App where
         -- you to use normal widget features in default-layout.
 
         pc <- widgetToPageContent $(widgetFile "default-layout")
+        let globalTitle = toHtml . siteTitle . appSettings $ master
+            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.
     authRoute _ = Just $ AuthR LoginR
 
     -- Routes not requiring authentication.
-    isAuthorized (AuthR _) _ = return Authorized
-    isAuthorized HomeR _ = return Authorized
-    isAuthorized FaviconR _ = return Authorized
-    isAuthorized KeybaseR _ = return Authorized
-    isAuthorized RobotsR _ = return Authorized
-    isAuthorized (StaticR _) _ = return Authorized
+    isAuthorized _ _ = return Authorized
 
     -- This function creates static content files in the static folder
     -- and names them based on a hash of their content. This allows
@@ -142,7 +141,7 @@ instance Yesod App where
     addStaticContent ext mime content = do
         master <- getYesod
         let staticDir = appStaticDir $ appSettings master
-        addStaticContentExternal
+        external <- addStaticContentExternal
             minifym
             genFileName
             staticDir
@@ -150,6 +149,13 @@ instance Yesod App where
             ext
             mime
             content
+        case external of
+          (Just (Right (StaticR (StaticRoute filePath _), _))) -> liftIO $ do
+            let staticPath = ((staticDir ++ "/") ++) . T.unpack . T.intercalate "/" $ filePath
+            mode <- F.fileMode <$> F.getFileStatus staticPath
+            F.setFileMode staticPath $ mode `F.unionFileModes` F.groupReadMode
+          _ -> return ()
+        return external
       where
         -- Generate a unique filename based on the content itself
         genFileName lbs = "autogen-" ++ base64md5 lbs
@@ -163,11 +169,27 @@ instance Yesod App where
 
     makeLogger = return . appLogger
 
+leftMenuItems, rightMenuItems :: Maybe (UserId, User) -> [MenuItem]
+leftMenuItems _ = toMenuItem <$> take 5 allEntryKinds
+  where toMenuItem kind = pluralise kind `MenuItem` EntriesR kind
+rightMenuItems = loggedOutItems `maybe` loggedInItems
+  where loggedOutItems =
+          [ "log in" `MenuItem` AuthR LoginR
+          ]
+        loggedInItems (_id, user) =
+          [ userUsername user `MenuItem` HomeR
+          , "log out" `MenuItem` AuthR LogoutR
+          ]
+
 -- Define breadcrumbs.
 instance YesodBreadcrumbs App where
-  breadcrumb HomeR = return ("Home", Nothing)
-  breadcrumb (AuthR _) = return ("Login", Just HomeR)
-  breadcrumb  _ = return ("home", Nothing)
+  breadcrumb (AuthR _) = return ("log in", Just HomeR)
+  breadcrumb (EntriesR kind) = return (pluralise kind, Just HomeR)
+  breadcrumb (EntryR kind entryId) = do
+    (Entity _ entry) <- getCached entryId
+    return (entryTitle entry, Just $ EntriesR kind)
+  breadcrumb (EntryWithSlugR kind entryId _) = breadcrumb $ EntryR kind entryId
+  breadcrumb _ = return ("home", Nothing)
 
 -- How to run database actions.
 instance YesodPersist App where
@@ -185,25 +207,19 @@ instance YesodAuth App where
     loginDest _ = HomeR
     -- Where to send a user after logout
     logoutDest _ = HomeR
-    -- Override the above two destinations when a Referer: header is present
-    redirectToReferer _ = True
 
-    authenticate creds = runDB $ do
-        x <- getBy . UniqueUsername $ credsIdent creds
-        case x of
-            Just (Entity uid _) -> return $ Authenticated uid
-            Nothing -> Authenticated <$> insert User
-                { userUsername = credsIdent creds
-                , userFullName = ""
-                , userEmail = ""
-                , userNote = ""
-                }
+    authenticate = fmap toResult . lookupCreds
+      where
+        lookupCreds = runDB . getBy . UniqueUser . credsIdent
+        toResult = UserError AuthMsg.InvalidLogin `maybe` (Authenticated . entityKey)
 
     -- You can add other plugins like Google Email, email or OAuth here
-    authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins
-        -- Enable authDummy login if enabled.
-        where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]
-
+    authPlugins _ = [authHashDBWithForm loginForm (Just . UniqueUser)]
+      where loginForm :: Route App -> Widget
+            loginForm action = do
+              mtok <- reqToken <$> getRequest
+              setTitle "log in"
+              $(widgetFile "auth/login")
     authHttpManager = getHttpManager
 
 -- | Access function to determine if a user is logged in.
@@ -237,3 +253,7 @@ 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

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

@@ -0,0 +1,22 @@
+{-# 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,8 +7,15 @@
 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 Widget.Entry ( entryR )
+
 -- These handlers embed files in the executable at compile time to avoid a
 -- runtime dependency, and for efficiency.
 
@@ -21,6 +28,35 @@ getKeybaseR :: Handler TypedContent
 getKeybaseR = return $ TypedContent typePlain
                      $ toContent $(embedFile "config/keybase.txt")
 
-getRobotsR :: Handler TypedContent
-getRobotsR = return $ TypedContent typePlain
-                    $ toContent $(embedFile "config/robots.txt")
+getRobotsR :: Handler Text
+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
+            { sitemapLoc = HomeR
+            , sitemapLastMod = Nothing
+            , sitemapChangeFreq = Just Daily
+            , sitemapPriority = Nothing
+            }
+        yieldMany $ sitemapUrl . CategoryR . E.unValue <$> categories
+        yieldMany $ sitemapUrl . EntriesR <$> allEntryKinds
+        yieldMany $ entryToSitemapUrl <$> entries
+
+sitemapUrl :: a -> SitemapUrl a
+sitemapUrl loc = SitemapUrl
+    { sitemapLoc = loc
+    , sitemapLastMod = Nothing
+    , sitemapChangeFreq = Nothing
+    , sitemapPriority = Nothing
+    }
+
+entryToSitemapUrl :: Entity Entry -> SitemapUrl (Route App)
+entryToSitemapUrl entry = (sitemapUrl $ entryR entry)
+    { sitemapLastMod = Just . entryUpdated . entityVal $ entry
+    }

src/Handler/Entries.hs

@@ -0,0 +1,54 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Handler.Entries where
+
+import Import
+
+import Yesod.AtomFeed ( atomLink )
+
+import Model.Cache ( getCached )
+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
+        hFeed myTitle entries
+
+getEntryR :: a -> EntryId -> Handler Html
+getEntryR _ = renderEntry <=< getCached
+
+getEntryWithSlugR :: a -> EntryId -> b -> Handler Html
+getEntryWithSlugR kind = const . getEntryR kind
+
+renderEntry :: (Entity Entry) -> Handler Html
+renderEntry entry = do
+    let correctRoute = entryR entry
+    actualRoute <- getCurrentRoute
+    author <- getCached . entryAuthorId $ entityVal entry
+    when (actualRoute /= Just correctRoute) $
+        redirectWith movedPermanently301 correctRoute
+    defaultLayout $ do
+        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

@@ -0,0 +1,54 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+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
+
+getFeedR :: Handler TypedContent
+getFeedR = do
+    entries <- runDB $ selectList [] [Desc EntryPublished]
+    newsFeed $ toFeed entries
+
+getFeedKindR :: K.EntryKind -> Handler TypedContent
+getFeedKindR kind = do
+    entries <- runDB $ selectList [EntryKind ==. kind] [Desc EntryPublished]
+    let basicFeed = toFeed entries
+    newsFeed $ basicFeed
+        { feedTitle = T.concat [K.pluralise kind, " ~ ", feedTitle basicFeed]
+        , feedDescription = toHtml $ T.concat ["feed of all ", K.pluralise kind]
+        , feedLinkSelf = FeedKindR kind
+        , feedLinkHome = EntriesR kind
+        }
+
+toFeed :: [Entity Entry] -> Feed (Route App)
+toFeed entries@(latestEntry:_) = (toFeed [])
+    { feedEntries = toFeedEntry <$> entries
+    , feedUpdated = entryUpdated $ entityVal latestEntry
+    }
+toFeed [] = Feed
+    { feedTitle = siteTitle compileTimeAppSettings
+    , feedLinkSelf = FeedR
+    , feedLinkHome = HomeR
+    , feedAuthor = ""
+    , feedDescription = "sitewide feed of all entries"
+    , feedLanguage = "en-au"
+    , feedUpdated = posixSecondsToUTCTime 0
+    , feedLogo = Nothing
+    , feedEntries = []
+    }
+
+toFeedEntry :: Entity Entry -> FeedEntry (Route App)
+toFeedEntry entry = FeedEntry
+    { feedEntryLink = entryR entry
+    , feedEntryUpdated = entryUpdated $ entityVal entry
+    , feedEntryTitle = entryTitle $ entityVal entry
+    , feedEntryContent = toHtml . entryContent . entityVal $ entry
+    , feedEntryEnclosure = Nothing
+    }

src/Handler/Home.hs

@@ -1,19 +1,23 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 module Handler.Home where
 
 import Import
-import Widget.Hcard (hcard)
+
+import Yesod.AtomFeed ( atomLink )
+
+import Widget.Card ( hCard )
+import Widget.Feed ( hFeed )
 
 getHomeR :: Handler Html
 getHomeR = do
-    user <- runDB . getBy404 $ UniqueUsername "dani"
-    maybeTitle <- asks $ appTitle . appSettings
+    settings <- asks appSettings
+    user <- runDB . getBy404 . UniqueUser . siteUsername $ settings
+    let title = siteTitle settings
+    entries <- runDB $ selectList [EntryAuthorId ==. entityKey user] [Desc EntryPublished]
     defaultLayout $ do
-        case maybeTitle of
-          Just title -> setTitle $ toHtml title
-          Nothing -> return ()
+        atomLink FeedR title
         $(widgetFile "home")

src/Import.hs

@@ -3,4 +3,5 @@ module Import
     ) where
 
 import Foundation            as Import
+import Settings.StaticR      as Import
 import Import.NoFoundation   as Import

src/Model.hs

@@ -11,6 +11,13 @@ module Model where
 
 import ClassyPrelude.Yesod
 import Database.Persist.Quasi
+import Yesod.Auth.HashDB ( HashDBUser(..) )
+import Text.Mustache ( (~>) )
+import qualified Text.Mustache as M
+
+import Model.Category ( Category )
+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
@@ -18,3 +25,12 @@ import Database.Persist.Quasi
 -- http://www.yesodweb.com/book/persistent/
 share [mkPersist sqlSettings, mkMigrate "migrateAll"]
     $(persistFileWith lowerCaseSettings "config/models")
+
+instance HashDBUser User where
+  userPasswordHash = Just . userPassword
+  setPasswordHash pw u = u { userPassword = pw }
+
+instance M.ToMustache Profile where
+  toMustache p = M.object
+    [ "username" ~> profileUsername p
+    ]

src/Model/Cache.hs

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

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

@@ -0,0 +1,30 @@
+{-# 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/Entry/Kind.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Model.Entry.Kind where
+
+import Database.Persist.TH ( derivePersistField )
+import Yesod.Core.Dispatch ( PathPiece, toPathPiece, fromPathPiece )
+
+import qualified Data.Text as T
+import Text.Read ( readMaybe )
+
+data EntryKind = Note | Article | Photo | Video | Audio
+               | Reply | Repost | Like | Favourite | Bookmark | Quote | Rsvp
+               | Listen | Jam | Watch | Play | Read
+              deriving (Enum, Eq, Read, Show)
+derivePersistField "EntryKind"
+
+allEntryKinds :: [EntryKind]
+allEntryKinds = [Note ..]
+
+singularise :: T.Text -> Maybe EntryKind
+singularise "replies" = Just Reply
+singularise "watches" = Just Watch
+singularise k = readMaybe . T.unpack . T.toTitle . T.init $ k
+
+pluralise :: EntryKind -> T.Text
+pluralise Reply = "replies"
+pluralise Watch = "watches"
+pluralise k = T.toLower . flip T.snoc 's' . T.pack . show $ k
+
+instance PathPiece EntryKind where
+    toPathPiece = pluralise
+    fromPathPiece = singularise

src/Model/Markdown.hs

@@ -0,0 +1,38 @@
+{-# 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/Package.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Package ( Package(..)
+               , Repository(..)
+               , package
+               ) where
+
+import Data.Aeson ( eitherDecodeStrict )
+import Data.Either ( either )
+import Language.Haskell.TH.Syntax ( addDependentFile, lift, runIO )
+import Package.Types
+
+import qualified Data.ByteString as B
+
+package :: Package
+package = $(do
+    let f = "package.json"
+    addDependentFile f
+    json <- runIO $ B.readFile f
+    let result = eitherDecodeStrict json :: Either String Package
+    either fail lift result)

src/Package/Types.hs

@@ -0,0 +1,27 @@
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Package.Types where
+
+import Data.Aeson
+import Data.Aeson.Types ( fieldLabelModifier )
+import Data.Aeson.TH ( deriveJSON )
+
+import Data.Char ( toLower )
+import Language.Haskell.TH.Syntax ( Lift )
+import Util ( mapFirst )
+
+data Package = Package
+    { packageName :: !String
+    , packageVersion :: !String
+    , packageRepository :: !Repository
+    } deriving (Show, Lift)
+
+data Repository = Repository
+    { repositoryType :: !String
+    , repositoryUrl :: !String
+    } deriving (Show, Lift)
+
+$(deriveJSON defaultOptions { fieldLabelModifier = mapFirst toLower . drop 7 } ''Package)
+$(deriveJSON defaultOptions { fieldLabelModifier = mapFirst toLower . drop 10 } ''Repository)

src/SchemaOrg/BreadcrumbList.hs

@@ -0,0 +1,21 @@
+{-# 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,9 +19,8 @@ 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(wfsHamletSettings), widgetFileNoReload,
+import Yesod.Default.Util         (WidgetFileSettings, widgetFileNoReload,
                                    widgetFileReload)
 import qualified Database.MySQL.Base as MySQL
 
@@ -59,11 +58,14 @@ data AppSettings = AppSettings
     , appSkipCombining          :: Bool
     -- ^ Perform no stylesheet/script combining
 
-    -- Example app-specific configuration values.
-    , appAnalytics              :: Maybe Text
-    -- ^ Google Analytics code
-    , appTitle                  :: Maybe Text
+    , appFacebookId          :: Maybe Int
+    -- ^ Facebook app ID.
+
+    , 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.
@@ -92,8 +94,9 @@ instance FromJSON AppSettings where
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
 
-        appAnalytics              <- o .:? "analytics"
-        appTitle                  <- o .:? "title"
+        appFacebookId             <- o .:? "fb-app-id"
+        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
@@ -116,7 +119,7 @@ instance FromJSON AppSettings where
 --
 -- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
 widgetFileSettings :: WidgetFileSettings
-widgetFileSettings = def { wfsHamletSettings = defaultHamletSettings { hamletNewlines = AlwaysNewlines } }
+widgetFileSettings = def
 
 -- | How static files should be combined.
 combineSettings :: CombineSettings

src/Settings/StaticR.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+module Settings.StaticR ( staticR ) where
+
+import Foundation ( App, Route(StaticR) )
+import Settings ( appStaticDir, compileTimeAppSettings )
+import Yesod.Static ( Route(StaticRoute) )
+
+import Settings.StaticR.TH ( mkHashMap )
+
+import qualified Data.Map as M
+import qualified Data.Text as T
+
+staticR :: [T.Text] -> Route App
+staticR pieces = StaticR $ StaticRoute pieces params
+    where params = case pieces `M.lookup` staticMap of
+                     Just etag -> [("etag", etag)]
+                     Nothing -> []
+
+staticMap :: M.Map [T.Text] T.Text
+staticMap = M.fromList $(mkHashMap . appStaticDir $ compileTimeAppSettings)

src/Settings/StaticR/TH.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE TupleSections     #-}
+module Settings.StaticR.TH ( mkHashMap ) where
+
+import Conduit hiding ( lift )
+import Data.List.Split ( splitOn )
+import Language.Haskell.TH.Syntax ( Q, Exp, lift, runIO )
+import Yesod.Static ( base64md5 )
+
+import qualified Data.ByteString.Lazy as L
+
+base64md5File :: MonadIO m => FilePath -> m String
+base64md5File = fmap base64md5 . liftIO . L.readFile
+
+genHashPair :: MonadIO m => FilePath -> m ([String], String)
+genHashPair fp = (tail $ splitOn "/" fp,) <$> base64md5File fp
+
+genHashMap :: FilePath -> IO [([String], String)]
+genHashMap dir = runConduitRes
+               $ sourceDirectoryDeep True dir
+              .| mapMC genHashPair
+              .| sinkList
+
+mkHashMap :: FilePath -> Q Exp
+mkHashMap fp = lift =<< runIO (genHashMap fp)

src/Util.hs

@@ -0,0 +1,26 @@
+module Util ( compileMustache, entityToTuple, mapFirst ) where
+
+import Database.Persist ( Entity(..), Key )
+import Text.Mustache ( Template(..), compileTemplate )
+import Text.Mustache.Types ( Node(TextBlock) )
+import Text.Parsec.Error ( ParseError )
+
+import qualified Data.Text as T
+import qualified Data.HashMap.Lazy as M
+
+mapFirst :: (a -> a) -> [a] -> [a]
+mapFirst f (x:xs) = f x : xs
+mapFirst _ [] = []
+
+compileMustache :: String -> T.Text -> Template
+compileMustache n = either errorTemplate id . compileTemplate n
+
+errorTemplate :: ParseError -> Template
+errorTemplate err = Template
+    { name = "error"
+    , ast = [TextBlock . T.pack $ show err]
+    , partials = M.empty
+    }
+
+entityToTuple :: Entity t -> (Key t, t)
+entityToTuple (Entity key value) = (key, value)

src/Widget/Card.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Widget.Card ( hCard ) where
+
+import Import
+
+import Database.Esqueleto ( (^.) )
+import qualified Database.Esqueleto as E
+
+import Model.Markdown ( unMarkdown )
+import Text.Mustache ( substitute )
+import Util ( compileMustache )
+
+import qualified Data.Text as T
+
+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
+        E.on $ profile ^. ProfileSiteId E.==. site ^. SiteId
+        E.where_ $ profile ^. ProfileUserId E.==. E.val userId
+        E.orderBy [E.asc $ site ^. SiteName]
+        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

@@ -0,0 +1,42 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Widget.Entry ( entryR, hEntry ) where
+
+import Import
+
+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
+    , timeFriendly :: String
+    } deriving Eq
+
+toFormattedTime :: MonadIO m => UTCTime -> m FormattedTime
+toFormattedTime time = FormattedTime (unfriendly time) <$> friendly time
+    where unfriendly = formatTime defaultTimeLocale . iso8601DateFormat . Just $ "%H:%M:%S%z"
+          friendly = liftIO . humanReadableTime
+
+entryR :: Entity Entry -> Route App
+entryR (Entity entryId Entry {..}) = route (entryName >>= mkSlug) entryKind entryId
+    where route (Just s) = \k i -> EntryWithSlugR k i s
+          route Nothing  = EntryR
+
+hEntry :: Entity Entry -> Widget
+hEntry (Entity entryId entry) = do
+    published <- toFormattedTime . entryPublished $ entry
+    updated <- toFormattedTime . entryUpdated $ entry
+    posses <- handlerToWidget . runDB . E.select . E.from $ \(syndication `E.InnerJoin` profile `E.InnerJoin` site) -> do
+        E.on $ profile ^. ProfileSiteId E.==. site ^. SiteId
+        E.on $ syndication ^. SyndicationProfileId E.==. profile ^. ProfileId
+        E.where_ $ syndication ^. SyndicationEntryId E.==. E.val entryId
+        E.orderBy [E.asc $ site ^. SiteName]
+        return (syndication ^. SyndicationUrl, site ^. SiteIcon, E.coalesceDefault [profile ^. ProfileDisplayName] (profile ^. ProfileUsername))
+    maybeAuthor <- handlerToWidget . runDB . get . entryAuthorId $ entry
+    $(widgetFile "mf2/h-entry")

src/Widget/Feed.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Widget.Feed ( hFeed ) where
+
+import Import
+import Widget.Entry ( hEntry )
+
+import qualified Data.Text as T
+
+hFeed :: T.Text -> [Entity Entry] -> Widget
+hFeed name entries = do
+    mroute <- getCurrentRoute
+    $(widgetFile "mf2/h-feed")

src/Widget/Hcard.hs

@@ -1,41 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Widget.Hcard (hcard) where
-
-import Import
-import Data.Maybe (fromJust)
-import qualified Data.Map as M
-import qualified Data.Text as T
-import qualified Network.Libravatar as L
-
-libravatar :: (MonadIO m) => User -> m (Maybe Text)
-libravatar = liftIO . flip L.avatarUrl opts . L.Email . userEmail
-    where opts = def { L.optSecure = True, L.optSize = L.Size 512, L.optTryGravatar = False }
-
-entityToTuple :: Entity t -> (Key t, t)
-entityToTuple (Entity key value) = (key, value)
-
-arrangeProfiles :: M.Map (Key Site) Site -> [Profile] -> [(Site,Profile)]
-arrangeProfiles sites profiles = sortBy icon $ zip profileSites profiles
-    where findSite = fromJust . flip M.lookup sites . profileSiteId
-          profileSites = findSite <$> profiles
-          icon = comparing $ siteIcon . fst
-
-prettyPgp :: PgpKey -> Text
-prettyPgp = T.unwords . T.chunksOf 4 . pgpKeyFingerprint
-
-routeFromPgp :: PgpKey -> Route App
-routeFromPgp PgpKey { pgpKeyFingerprint = f, pgpKeyHash = h } =
-    StaticR $ StaticRoute ["pgp", f, h, T.takeEnd 8 f ++ ".asc"] []
-
-hcard :: Entity User -> Widget
-hcard (Entity userId user) = do
-    maybeAvatar <- libravatar user
-    mcurrentRoute <- getCurrentRoute
-    userProfiles <- handlerToWidget . runDB $ do
-        profiles <- map entityVal <$> selectList [ProfileUserId ==. userId] []
-        sites <- M.fromList . map entityToTuple <$> selectList [SiteId <-. (profileSiteId <$> profiles)] []
-        return $ arrangeProfiles sites profiles
-    pgpKeys <- handlerToWidget . runDB $ map entityVal <$> selectList [PgpKeyUserId ==. userId] []
-    $(widgetFile "hcard")

stack.yaml

@@ -39,8 +39,7 @@ packages:
 - .
 # Dependency packages to be pulled from upstream that are not in the resolver
 # (e.g., acme-missiles-0.3)
-extra-deps:
-- libravatar-0.4.0.1
+extra-deps: []
 
 # Override default flag values for local packages and extra-deps
 flags: {}

static/openwebicons

@@ -0,0 +1 @@
+../node_modules/openwebicons/

templates/auth/login.cassius

@@ -0,0 +1,14 @@
+body > main
+  display: flex
+  align-items: center
+  justify-content: center
+  .form-control
+    background-color: #1d1f21
+    color: #c9cacc
+    &:focus
+      background-color: #404449
+      color: #c9cacc
+  .input-group-addon
+    background-color: #000
+    color: #fff
+    width: 2.4rem

templates/auth/login.hamlet

@@ -0,0 +1,24 @@
+<form .container method="post" action=@{action}>
+  $maybe tok <- mtok
+    <input type="hidden" name=#{defaultCsrfParamName} value=#{tok}>
+
+  <div .card.bg-dark>
+    <div .card-body>
+      <div .form-group>
+        <label .sr-only for="auth-login-username">username
+        <div .input-group>
+          <span .input-group-addon aria-hidden>
+            <i .fa.fa-at>
+          <input #auth-login-username .form-control type="text" name="username" placeholder="username" required>
+
+      <div .form-group>
+        <label .sr-only for="auth-login-password">password
+        <div .input-group>
+          <span .input-group-addon aria-hidden>
+            <i .fa.fa-asterisk>
+          <input #auth-login-password .form-control type="password" name="password" placeholder="password" required>
+
+    <div .card-footer>
+      <button type="submit" class="btn btn-primary">
+        <i .fa.fa-sign-in>
+        log in

templates/default-layout-wrapper.hamlet

@@ -3,50 +3,25 @@ $doctype 5
   <head>
     <meta charset="utf-8">
     <meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no">
+    <meta name="generator" content="#{packageName package} #{packageVersion package}">
 
-    <title>#{pageTitle pc}
-    <meta name="description" content="">
-    <meta name="author" content="">
+    <title>#{fullTitle}
     $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">
+    <link rel="stylesheet" href=@{StaticR openwebicons_css_openwebicons_min_css}>
     <script src="https://use.fontawesome.com/4fbab4ae27.js">
 
     ^{pageHead pc}
 
-    <script>
-      /* The `defaultCsrfMiddleware` Middleware added in Foundation.hs adds a CSRF token to the request cookies. */
-      /* AJAX requests should add that token to a header to be validated by the server. */
-      /* See the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package for details. */
-      var csrfHeaderName = "#{TE.decodeUtf8 $ CI.foldedCase defaultCsrfHeaderName}";
-
-      var csrfCookieName = "#{TE.decodeUtf8 defaultCsrfCookieName}";
-      var csrfToken = Cookies.get(csrfCookieName);
-
-
-      if (csrfToken) {
-      \  $.ajaxPrefilter(function( options, originalOptions, jqXHR ) {
-      \      if (!options.crossDomain) {
-      \          jqXHR.setRequestHeader(csrfHeaderName, csrfToken);
-      \      }
-      \  });
-      }
-
   <body>
     ^{pageBody pc}
 
     <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

@@ -1,7 +1,19 @@
 a
   color: #00a6f9
-a:hover
-  color: #0084d6
+  &:hover
+    color: #0084d6
+
+  [class^="openwebicons-"], [class*=" openwebicons-"]
+    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
@@ -10,6 +22,17 @@ body
   min-height: 100vh
   > main
     flex: 1
+    margin: 2em
   > footer
     text-align: center
     padding-bottom: 1em
+    display: flex
+    justify-content: space-evenly
+    margin: auto 1em
+#navbar
+  justify-content: space-between
+.breadcrumb
+  background-color: #404449
+  border-radius: 0
+  .breadcrumb-item.active
+    color: #fff

templates/default-layout.hamlet

@@ -1,26 +1,23 @@
 <header>
-    <nav .navbar .navbar-expand-lg .navbar-dark.bg-dark>
-        $maybe title <- appTitle $ appSettings master
-            <a .navbar-brand href=@{HomeR}>#{title}
+    <nav .navbar .navbar-expand-md .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>
 
         <div #navbar .collapse.navbar-collapse>
-            <ul .navbar-nav.mr-auto>
-                $forall MenuItem label route _ <- navbarLeftFilteredMenuItems
-                    <li .nav-item :Just route == mcurrentRoute:.active>
-                        <a .nav-link href=@{route}>#{label}
+            $forall bar <- navbars
+                <ul .navbar-nav>
+                    $forall MenuItem label route <- bar
+                        <li .nav-item :Just route == mcurrentRoute:.active>
+                            <a .nav-link href=@{route}>#{label}
 
-            <ul .navbar-nav>
-                $forall MenuItem label route _ <- navbarRightFilteredMenuItems
-                    <li .nav-item :Just route == mcurrentRoute:.active>
-                        <a .nav-link href=@{route}>#{label}
-    $if not $ null parents
-        <ul .breadcrumb.rounded-0>
-            $forall bc <- parents
+    $if not $ null crumbs
+        <ol .breadcrumb>
+            $forall (route, title) <- crumbs
                 <li .breadcrumb-item>
-                    <a href=@{fst bc}>#{snd bc}
+                    <a href=@{route}>#{title}
             <li .breadcrumb-item.active>#{title}
+        <script type="application/ld+json">#{preEscapedToMarkup jsonCrumbs}
     $maybe msg <- mmsg
       <div .alert.alert-info #message>#{msg}
 
@@ -28,5 +25,10 @@
     ^{widget}
 
 <footer>
-    All content on this site is licensed under
-    a <a rel="license" href="//creativecommons.org/licenses/by-sa/4.0/">Creative Commons Attribution-ShareAlike 4.0 International License</a>.
+    <p>
+        all content licensed under #
+        <a rel="license" href="https://creativecommons.org/licenses/by-sa/4.0/">cc by-sa 4.0
+    $with Package { packageName = n, packageVersion = v, packageRepository = r } <- package
+        <p>
+            powered by #
+            <a rel="code-repository" href="#{repositoryUrl r}/tree/v#{v}">#{n} #{v}

templates/hcard.hamlet

@@ -1,26 +0,0 @@
-<div .card.h-card .bg-dark>
-  $maybe route <- mcurrentRoute
-    <a .u-uid.u-url rel="me" href=@{route} hidden>
-
-  $maybe avatar <- maybeAvatar
-    <img .card-img-top.u-photo src=#{avatar} alt="Avatar for #{userFullName user}">
-
-  <div .card-body>
-    <h4 .card-title.p-name>#{userFullName user}
-    $forall key <- pgpKeys
-      <a .card-subtitle.u-key rel="me" href=@{routeFromPgp key}>
-        <i .fa.fa-key>
-        #{prettyPgp key}
-        <link rel="pgpkey" type="application/pgp-keys" href=@{routeFromPgp key}>
-    <p .card-text.p-note .text-muted>#{userNote user}
-
-    <ul .profiles>
-      <li>
-        <a .u-email rel="me" href="mailto:#{userEmail user}">
-          <i .fa.fa-envelope>
-          #{userEmail user}
-      $forall (site, profile) <- userProfiles
-        <li>
-          <a .u-url rel="me" href="#{siteUrl site}#{profileUsername profile}">
-            <i .fa.fa-#{siteIcon site}>
-            #{profileUsername profile}

templates/home.cassius

@@ -0,0 +1,22 @@
+body > main
+  display: flex
+  flex-direction: column
+  align-items: center
+  > div.h-feed
+    flex: 1
+    margin-bottom: 0
+  > aside.author
+    max-width: 25rem
+    margin-bottom: 2em
+    > .h-card
+      position: sticky
+      top: 1em
+
+@media (min-width: 768px)
+  body > main
+    flex-direction: row-reverse
+    align-items: unset
+    > div.h-feed
+      margin-right: 2em
+    > aside.author
+      margin-bottom: 0

templates/home.hamlet

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

templates/mf2/h-card.cassius

@@ -1,7 +1,4 @@
 .card.h-card
-  margin: 2em auto
-  width: 22rem
-
   ul.profiles
     list-style: none
     padding-left: 0

templates/mf2/h-card.hamlet

@@ -0,0 +1,27 @@
+<article .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}>
+
+  <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}>
+        <i .fa.fa-key>
+        #{prettyPgp key}
+    <div .p-note itemprop="description" .text-muted>#{userNote user}
+
+    <ul .profiles>
+      <li>
+        <a .u-email rel="me" itemprop="email" href="mailto:#{userEmail user}">
+          <i .fa.fa-envelope>
+          #{userEmail user}
+      $forall (Entity _ site, Entity _ profile) <- userProfiles
+        <li>
+          <a .u-url rel="me" itemprop="sameAs" href="#{profileUrl site profile}">
+            <i .#{siteIcon site}>
+            $maybe name <- profileDisplayName profile
+              #{name}
+            $nothing
+              #{profileUsername profile}

templates/mf2/h-entry.cassius

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

@@ -0,0 +1,36 @@
+<article .h-entry .card.bg-dark itemscope itemtype="http://schema.org/BlogPosting">
+  $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 itemprop="headline">#{name}
+      <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}>
+        <img .u-photo src=@{AvatarR $ entryAuthorId entry} alt=#{userFullName author}>
+        #{userFullName author}
+      $# Use a separate hidden block for the schema.org metadata because you
+      $# 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}>
+      <i .fa.fa-calendar>
+      #{timeFriendly published}
+    <time .dt-updated itemprop="dateModified" datetime=#{timeUnfriendly updated} title=#{timeUnfriendly updated} :published == updated:hidden>
+      <i .fa.fa-pencil>
+      #{timeFriendly updated}
+    $forall (E.Value url, E.Value icon, E.Value name) <- posses
+      <a .u-syndication href=#{url}>
+        <i .#{icon}>
+        #{name}

templates/mf2/h-feed.cassius

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

templates/mf2/h-feed.hamlet

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