chore(web): Delete //web/tazblog

Deleting this code feels strange. This project has been around for a
decade, and despite occasionally needing a bunch of tweaks it had aged
well and worked fine for a very long time.

I've reached a strange point where I don't really feel like using
Haskell anymore, and every interaction with this project in recent
years has been fighting dependency management tooling for Haskell, or
dealing with strange build problems.

The simple fact is that the service never really did anything other
than render Markdown dynamically, and at this point I can do that much
better with //tools/cheddar instead.

So, tazblog-hs, it's time to say goodbye. Rest in peace!
This commit is contained in:
Vincent Ambo 2020-02-09 00:43:40 +00:00
parent 9fc9b58301
commit 05ab6825b3
14 changed files with 0 additions and 679 deletions

View file

@ -25,5 +25,4 @@ in with pkgs; [
third_party.git
third_party.guile
third_party.lisp # will build all third-party libraries
# web.tazblog # TODO(tazjin): Happstack build failure in nixos-unstable
]

View file

@ -1,24 +0,0 @@
-- | Main module for the blog's web server
module Main where
import Control.Applicative ((<$>), (<*>))
import Server (runBlog)
import System.Environment (getEnv)
data MainOptions
= MainOptions
{ blogPort :: Int,
resourceDir :: String
}
readOpts :: IO MainOptions
readOpts =
MainOptions
<$> (fmap read $ getEnv "PORT")
<*> getEnv "RESOURCE_DIR"
main :: IO ()
main = do
opts <- readOpts
putStrLn ("tazblog starting on port " ++ (show $ blogPort opts))
runBlog (blogPort opts) (resourceDir opts)

View file

@ -1,18 +0,0 @@
# Build configuration for the blog using plain Nix.
#
# tazblog.nix was generated using cabal2nix.
{ pkgs, ... }:
let
inherit (pkgs.third_party) writeShellScriptBin haskell;
tazblog = haskell.packages.ghc865.callPackage ./tazblog.nix {};
wrapper = writeShellScriptBin "tazblog" ''
export PORT=8000
export RESOURCE_DIR=${./static}
exec ${tazblog}/bin/tazblog
'';
in wrapper.overrideAttrs(_: {
allowSubstitutes = true;
meta.enableCI = true;
})

View file

@ -1,11 +0,0 @@
{ pkgs ? (import ../../default.nix {}).third_party.nixpkgs }:
let tazblog = import ./tazblog.nix;
depNames = with builtins; filter (
p: hasAttr p pkgs.haskellPackages
) (attrNames (functionArgs tazblog));
ghc = pkgs.ghc.withPackages(p: map (x: p."${x}") depNames);
in pkgs.stdenv.mkDerivation {
name = "shell";
buildInputs = [ ghc pkgs.hlint ];
}

View file

@ -1,141 +0,0 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Blog where
import BlogStore
import Data.Text (Text, pack)
import qualified Data.Text as T
import Data.Text.Lazy (fromStrict)
import Data.Time
import Text.Blaze.Html (preEscapedToHtml)
import Text.Hamlet
import Text.Markdown
blogTitle :: Text = "tazjin's blog"
repoURL :: Text = "https://bitbucket.org/tazjin/tazblog-haskell"
mailTo :: Text = "mailto:mail@tazj.in"
twitter :: Text = "https://twitter.com/tazjin"
replace :: Eq a => a -> a -> [a] -> [a]
replace x y = map (\z -> if z == x then y else z)
-- |After this date all entries are Markdown
markdownCutoff :: Day
markdownCutoff = fromGregorian 2013 04 28
blogTemplate :: Text -> Html -> Html
blogTemplate t_append body =
[shamlet|
$doctype 5
<head>
<meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1">
<meta name="description" content=#{blogTitle}#{t_append}>
<link rel="stylesheet" type="text/css" href="/static/blog.css" media="all">
<link rel="alternate" type="application/rss+xml" title="RSS-Feed" href="/rss.xml">
<title>#{blogTitle}#{t_append}
<body>
<header>
<h1>
<a href="/" .unstyled-link>#{blogTitle}
<hr>
^{body}
^{showFooter}
|]
showFooter :: Html
showFooter =
[shamlet|
<footer>
<p .footer>Served without any dynamic languages.
<p .footer>
<a href=#{repoURL} .uncoloured-link>
|
<a href=#{twitter} .uncoloured-link>Twitter
|
<a href=#{mailTo} .uncoloured-link>Mail
<p .lod>
_ಠ
|]
isEntryMarkdown :: Entry -> Bool
isEntryMarkdown e = edate e > markdownCutoff
renderEntryMarkdown :: Text -> Html
renderEntryMarkdown = markdown def {msXssProtect = False} . fromStrict
renderEntries :: [Entry] -> Maybe Html -> Html
renderEntries entries pageLinks =
[shamlet|
$forall entry <- entries
<article>
<h2 .inline>
<a href=#{linkElems entry} .unstyled-link>
#{title entry}
<aside .date>
#{pack $ formatTime defaultTimeLocale "%Y-%m-%d" $ edate entry}
$if (isEntryMarkdown entry)
^{renderEntryMarkdown $ text entry}
$else
^{preEscapedToHtml $ text entry}
<hr>
$maybe links <- pageLinks
^{links}
|]
where
linkElems Entry {..} = "/" ++ show entryId
showLinks :: Maybe Int -> Html
showLinks (Just i) =
[shamlet|
$if ((>) i 1)
<div .navigation>
<a href=#{nLink $ succ i} .uncoloured-link>Earlier
|
<a href=#{nLink $ pred i} .uncoloured-link>Later
$elseif ((<=) i 1)
^{showLinks Nothing}
|]
where
nLink page = T.concat ["/?page=", show' page]
showLinks Nothing =
[shamlet|
<div .navigation>
<a href="/?page=2" .uncoloured-link>Earlier
|]
renderEntry :: Entry -> Html
renderEntry e@Entry {..} =
[shamlet|
<article>
<h2 .inline>
#{title}
<aside .date>
#{pack $ formatTime defaultTimeLocale "%Y-%m-%d" edate}
$if (isEntryMarkdown e)
^{renderEntryMarkdown text}
$else
^{preEscapedToHtml $ text}
<hr>
|]
showError :: Text -> Text -> Html
showError title err =
blogTemplate (": " <> title)
[shamlet|
<p>:(
<p>#{err}
<hr>
|]

View file

@ -1,182 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
-- |This module implements fetching of individual blog entries from
-- DNS. Yes, you read that correctly.
--
-- Each blog post is stored as a set of records in a designated DNS
-- zone. For the production blog, this zone is `blog.tazj.in.`.
--
-- A top-level record at `_posts` contains a list of all published
-- post IDs.
--
-- For each of these post IDs, there is a record at `_meta.$postID`
-- that contains the title and number of post chunks.
--
-- For each post chunk, there is a record at `_$chunkID.$postID` that
-- contains a base64-encoded post fragment.
--
-- This module implements logic for assembling a post out of these
-- fragments and caching it based on the TTL of its `_meta` record.
module BlogStore
( BlogCache,
EntryId (..),
Entry (..),
withCache,
listEntries,
getEntry,
show'
)
where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (mzero)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson ((.:), FromJSON (..), Value (Object), decodeStrict)
import Data.ByteString.Base64 (decodeLenient)
import Data.Either (fromRight)
import Data.List (sortBy)
import Data.Text as T (Text, concat, pack)
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Data.Time (Day)
import Network.DNS (DNSError, lookupTXT)
import qualified Network.DNS.Resolver as R
newtype EntryId = EntryId {unEntryId :: Integer}
deriving (Eq, Ord, FromJSON)
instance Show EntryId where
show = show . unEntryId
data Entry
= Entry
{ entryId :: EntryId,
author :: Text,
title :: Text,
text :: Text,
edate :: Day
}
deriving (Eq, Ord, Show)
-- | Wraps a DNS resolver with caching configured. For the initial
-- version of this, all caching of entries is done by the resolver
-- (i.e. no pre-assembled versions of entries are cached).
data BlogCache = BlogCache R.Resolver Text
data StoreError
= PostNotFound EntryId
| DNS DNSError
| InvalidMetadata
| InvalidChunk
| InvalidPosts
deriving (Show)
type Offset = Int
type Count = Int
withCache :: Text -> (BlogCache -> IO a) -> IO a
withCache zone f = do
let conf =
R.defaultResolvConf
{ R.resolvCache = Just R.defaultCacheConf,
R.resolvConcurrent = True
}
seed <- R.makeResolvSeed conf
R.withResolver seed (\r -> f $ BlogCache r zone)
listEntries :: MonadIO m => BlogCache -> Offset -> Count -> m [Entry]
listEntries cache offset count = liftIO $ do
posts <- postList cache
entries <- mapM (entryFromDNS cache) $ take count $ drop offset $ fromRight (error "no posts") posts
-- TODO: maybe don't just drop broken entries
return
$ fromRight (error "no entries")
$ sequence entries
getEntry :: MonadIO m => BlogCache -> EntryId -> m (Maybe Entry)
getEntry cache eid = liftIO $ entryFromDNS cache eid >>= \case
Left _ -> return Nothing -- TODO: ??
Right entry -> return $ Just entry
show' :: Show a => a -> Text
show' = pack . show
-- * DNS fetching implementation
type Chunk = Integer
-- | Represents the metadata stored for each post in the _meta record.
data Meta = Meta Integer Text Day
deriving (Show)
instance FromJSON Meta where
parseJSON (Object v) =
Meta
<$> v
.: "c"
<*> v
.: "t"
<*> v
.: "d"
parseJSON _ = mzero
entryMetadata :: BlogCache -> EntryId -> IO (Either StoreError Meta)
entryMetadata (BlogCache r z) (EntryId eid) =
let domain = encodeUtf8 ("_meta." <> show' eid <> "." <> z)
record = lookupTXT r domain
toMeta rrdata = case decodeStrict $ decodeLenient rrdata of
Nothing -> Left InvalidMetadata
Just m -> Right m
in record >>= \case
(Left err) -> return $ Left $ DNS err
(Right [bs]) -> return $ toMeta bs
_ -> return $ Left InvalidMetadata
entryChunk :: BlogCache -> EntryId -> Chunk -> IO (Either StoreError Text)
entryChunk (BlogCache r z) (EntryId eid) c =
let domain = encodeUtf8 ("_" <> show' c <> "." <> show' eid <> "." <> z)
record = lookupTXT r domain
toChunk rrdata = case decodeUtf8' $ decodeLenient rrdata of
Left _ -> Left InvalidChunk
Right chunk -> Right chunk
in record >>= \case
(Left err) -> return $ Left $ DNS err
(Right [bs]) -> return $ toChunk bs
_ -> return $ Left InvalidChunk
fetchAssembleChunks :: BlogCache -> EntryId -> Meta -> IO (Either StoreError Text)
fetchAssembleChunks cache eid (Meta n _ _) = do
chunks <- mapM (entryChunk cache eid) [0 .. (n - 1)]
return $ fmap T.concat $ sequence chunks
entryFromDNS :: BlogCache -> EntryId -> IO (Either StoreError Entry)
entryFromDNS cache eid = do
meta <- entryMetadata cache eid
case meta of
Left err -> return $ Left err
Right meta -> do
chunks <- fetchAssembleChunks cache eid meta
let (Meta _ t d) = meta
return
$ either Left
( \text -> Right $ Entry
{ entryId = eid,
author = "tazjin",
title = t,
text = text,
edate = d
}
)
chunks
postList :: BlogCache -> IO (Either StoreError [EntryId])
postList (BlogCache r z) =
let domain = encodeUtf8 ("_posts." <> z)
record = lookupTXT r domain
toPosts =
fmap (sortBy (flip compare))
. mapM (maybe (Left InvalidPosts) Right . decodeStrict)
in either (Left . DNS) toPosts <$> record

View file

@ -1,48 +0,0 @@
{-# LANGUAGE RecordWildCards #-}
module RSS
( renderFeed
)
where
import BlogStore
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Data.Time (UTCTime (..), getCurrentTime, secondsToDiffTime)
import Network.URI (URI, parseURI)
import Text.RSS
createChannel :: UTCTime -> [ChannelElem]
createChannel now =
[ Language "en",
Copyright "Vincent Ambo",
WebMaster "mail@tazj.in",
ChannelPubDate now
]
createRSS :: UTCTime -> [Item] -> RSS
createRSS t =
let link = fromJust $ parseURI "https://tazj.in"
in RSS "tazjin's blog" link "tazjin's blog feed" (createChannel t)
createItem :: Entry -> Item
createItem Entry {..} =
[ Title "tazjin's blog",
Link $ entryLink entryId,
Description $ T.unpack text,
PubDate $ UTCTime edate $ secondsToDiffTime 0
]
entryLink :: EntryId -> URI
entryLink i =
let url = "http://tazj.in/" ++ "/" ++ show i
in fromJust $ parseURI url
createItems :: [Entry] -> [Item]
createItems = map createItem
createFeed :: [Entry] -> IO RSS
createFeed e = getCurrentTime >>= (\t -> return $ createRSS t $ createItems e)
renderFeed :: [Entry] -> IO String
renderFeed e = fmap (showXML . rssToXML) (createFeed e)

View file

@ -1,81 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Server where
import Blog
import BlogStore
import Control.Applicative (optional)
import Control.Monad (msum)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (maybe)
import qualified Data.Text as T
import Happstack.Server hiding (Session)
import RSS
pageSize :: Int
pageSize = 3
tmpPolicy :: BodyPolicy
tmpPolicy = defaultBodyPolicy "/tmp" 0 200000 1000
runBlog :: Int -> String -> IO ()
runBlog port respath =
withCache "blog.tazj.in." $ \cache ->
simpleHTTP nullConf {port = port} $ tazblog cache respath
tazblog :: BlogCache -> String -> ServerPart Response
tazblog cache resDir =
msum
[ -- legacy language-specific routes
dir "de" $ blogHandler cache,
dir "en" $ blogHandler cache,
dir "static" $ staticHandler resDir,
blogHandler cache,
staticHandler resDir,
notFound $ toResponse $ showError "Not found" "Page not found"
]
blogHandler :: BlogCache -> ServerPart Response
blogHandler cache =
msum
[ path $ \(eId :: Integer) -> showEntry cache $ EntryId eId,
nullDir >> showIndex cache,
dir "rss" $ nullDir >> showRSS cache,
dir "rss.xml" $ nullDir >> showRSS cache
]
staticHandler :: String -> ServerPart Response
staticHandler resDir = do
setHeaderM "cache-control" "max-age=630720000"
setHeaderM "expires" "Tue, 20 Jan 2037 04:20:42 GMT"
serveDirectory DisableBrowsing [] resDir
showEntry :: BlogCache -> EntryId -> ServerPart Response
showEntry cache eId = do
entry <- getEntry cache eId
tryEntry entry
tryEntry :: Maybe Entry -> ServerPart Response
tryEntry Nothing = notFound $ toResponse $ showError "Not found" "Blog entry not found"
tryEntry (Just entry) = ok $ toResponse $ blogTemplate eTitle $ renderEntry entry
where
eTitle = T.append ": " (title entry)
offset :: Maybe Int -> Int
offset = maybe 0 (pageSize *)
showIndex :: BlogCache -> ServerPart Response
showIndex cache = do
(page :: Maybe Int) <- optional $ lookRead "page"
entries <- listEntries cache (offset page) pageSize
ok $ toResponse $ blogTemplate ""
$ renderEntries entries (Just $ showLinks page)
showRSS :: BlogCache -> ServerPart Response
showRSS cache = do
entries <- listEntries cache 0 4
feed <- liftIO $ renderFeed entries
setHeaderM "content-type" "text/xml"
ok $ toResponse feed

Binary file not shown.

Before

Width:  |  Height:  |  Size: 9.5 KiB

View file

@ -1,35 +0,0 @@
body {
margin: 40px auto;
max-width: 650px;
line-height: 1.6;
font-size: 18px;
color: #383838;
padding: 0 10px
}
h1, h2, h3 {
line-height: 1.2
}
.footer {
text-align: right;
}
.lod {
text-align: center;
}
.unstyled-link {
color: inherit;
text-decoration: none;
}
.uncoloured-link {
color: inherit;
}
.date {
text-align: right;
font-style: italic;
float: right;
}
.inline {
display: inline;
}
.navigation {
text-align: center;
}

Binary file not shown.

Before

Width:  |  Height:  |  Size: 4.3 KiB

View file

@ -1,69 +0,0 @@
==================================================================
https://keybase.io/tazjin
--------------------------------------------------------------------
I hereby claim:
* I am an admin of http://tazj.in
* I am tazjin (https://keybase.io/tazjin) on keybase.
* I have a public key with fingerprint DCF3 4CFA C1AC 44B8 7E26 3331 36EE 3481 4F6D 294A
To claim this, I am signing this object:
{
"body": {
"key": {
"fingerprint": "dcf34cfac1ac44b87e26333136ee34814f6d294a",
"host": "keybase.io",
"key_id": "36EE34814F6D294A",
"uid": "2268b75a56bb9693d3ef077bc1217900",
"username": "tazjin"
},
"service": {
"hostname": "tazj.in",
"protocol": "http:"
},
"type": "web_service_binding",
"version": 1
},
"ctime": 1397644545,
"expire_in": 157680000,
"prev": "4973fdda56a6cfa726a813411c915458c652be45dd19283f7a4ae4f9c217df14",
"seqno": 4,
"tag": "signature"
}
with the aforementioned key, yielding the PGP signature:
-----BEGIN PGP MESSAGE-----
Version: GnuPG v2.0.22 (GNU/Linux)
owGbwMvMwMWY9pU1Q3bHF2vG0wdeJTEE+8WyVSsl5adUKllVK2Wngqm0zLz01KKC
osy8EiUrpZTkNGOT5LTEZMPEZBOTJAvzVCMzY2NjQ2Oz1FRjEwtDkzSzFCNLk0Ql
HaWM/GKQDqAxSYnFqXqZ+UAxICc+MwUoamzm6gpW72bmAlTvCJQrBUsYGZlZJJmb
JpqaJSVZmlkapxinphmYmyclGxoZmlsaGIAUFqcW5SXmpgJVlyRWZWXmKdXqKAHF
yjKTU0EuBlmMJK8HVKCjVFCUX5KfnJ8DFMwoKSmwAukpqSwAKSpPTYqHao9PysxL
AXoYqKEstag4Mz9PycoQqDK5JBNknqGxpbmZiYmpiamOUmpFQWZRanwmSIWpuZmF
ARCArEktAxppYmlunJaSAvRFohkwtMyNzBItDI1NDA2TLQ2Bui2SzUyNklJNTFNS
DC2NLIzTzBNNElNN0iyTgZ5MSTM0UQJ5qDAvX8nKBOjMxHSgkcWZ6XmJJaVFqUq1
nUwyLAyMXAxsrEygKGPg4hSARWSZH/8/0573HMdvfH5XxeayYZ2efPb8bw730i1/
WBU3qru5pKlf3xKmeK5ihtKeT6VXGm3usV2reZWyvO/0joi83oT9P80s88Q6U/vb
vmycHnB7e110v/3OZadu/Sx6+uXk/ZeCR8u+p/+6dNc8XWqX/68t06pnrGKU/BfU
F7X5S/HUy4ysvyZN+v1Jj6NtMvvN1EvPpCpv3kz2tGU1EzpZFfl8Xujq1OopuxZJ
l5kvDlgZ78ezdLZ1+aOlixbsXra4/3fdbZ8XnQX1DatzV18+e2rmMcPKm6qngqIf
Xp8oKTAz+Mg1v6gHP0wLN/Mf3JKjYHnX5U6L/KIvkbsLArtES0r7w1iWZ3OvvSPr
fW6heune1tOb7j3vP+1XeOyV2ekr6pPO3bdrv9X25HbTaqs7z06f0v35fmtQ3uUZ
Z35eLYmaEmb/x/u3vFh6GsvMDocpCTpPlHa0z+xzOGbhzLFO18v21Zd9ISG3Hqtd
F7jaLlWa2W+TsytNnXudVrfCBSbl8zNMfuk2e0Z8i9ix3PmEVa3rTEfhde3qwgtY
dy8rUbzzd5d9ccF63btqO/VMb4oe04x4uCLB5RD3p+8+s77o/T4WP2cFw+0cviX6
StlJX5f+U3Or3fZY7dUfPcmMJZ/eSs7m+1d5IUbs3jI27olHFzGVvTcsu7w79aOK
SxmXvnEIUwZXgP6BL4LrPDY1rN2V0q1cZj1/efj880rzeu6+OQYA
=xHfH
-----END PGP MESSAGE-----
And finally, I am proving ownership of this host by posting or
appending to this document.
View my publicly-auditable identity here: https://keybase.io/tazjin
==================================================================

View file

@ -1,39 +0,0 @@
Name: tazblog
Version: 6.0.0
Synopsis: Tazjin's Blog
License: MIT
Author: Vincent Ambo
Maintainer: mail@tazj.in
Category: Web blog
Build-type: Simple
cabal-version: >= 1.10
library
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -W
exposed-modules: Blog, BlogStore, Server, RSS
build-depends: aeson,
base,
bytestring,
happstack-server,
text,
blaze-html,
dns,
old-locale,
time,
base64-bytestring,
network,
network-uri,
rss,
shakespeare,
markdown
executable tazblog
hs-source-dirs: blog
main-is: Main.hs
default-language: Haskell2010
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base,
tazblog,
network

View file

@ -1,30 +0,0 @@
{ mkDerivation, aeson, base, base64-bytestring, blaze-html , bytestring, dns
, happstack-server, markdown, network, network-uri, old-locale, rss
, shakespeare, stdenv, text, time }:
mkDerivation {
pname = "tazblog";
version = "6.0.0";
src = ./.;
isLibrary = true;
isExecutable = true;
libraryHaskellDepends = [
aeson
base
base64-bytestring
blaze-html
bytestring
dns
happstack-server
markdown
network
network-uri
old-locale
rss
shakespeare
text
time
];
executableHaskellDepends = [ base network ];
description = "Tazjin's Blog";
license = stdenv.lib.licenses.mit;
}