Commit 74666330a31e2bf56ab598684c8826931f362a5d - new-inf-blog

+12

-1

new-inf-blog.cabal less more

14	14	hs-source-dirs: src
15	15	main-is: Main.hs
16	16	other-modules: Inf.Types
	17	Inf.Templates
17	18	Inf.DB
	19	Inf.DB.Monad
	20	Inf.Feed
18	21	default-language: Haskell2010
19	22	default-extensions: ScopedTypeVariables
20	23	ghc-options: -Wall

24	27	, stache
25	28	, text
26	29	, time
27		, ~~sqlite-simple~~⏎
	30	, http-types
	31	, sqlite-simple
	32	, aeson
	33	, filepath
	34	, pandoc
	35	, feed
	36	, xml-types
	37	, xml-conduit
	38	, bytestring⏎

+89

-0

src/Inf/DB/Monad.hs less more

	1	{-# LANGUAGE GADTs #-}
	2	{-# LANGUAGE RankNTypes #-}
	3
	4	module Inf.DB.Monad
	5	( DB(..)
	6	, DBException(..)
	7	, SQL.Only(..)
	8	, SQL.Connection
	9	, io
	10	, raise
	11	, f
	12
	13	, query
	14	, queryMb
	15	, queryOne
	16	, execute
	17	, lastRow
	18
	19	, SQL.open
	20	) where
	21
	22	import qualified Control.Exception as Exn
	23	import qualified Database.SQLite.Simple as SQL
	24	import qualified Database.SQLite.Simple.ToField as SQL
	25
	26	import Inf.Types
	27
	28	newtype DB r = DB { runDB :: SQL.Connection -> IO r }
	29
	30	instance Functor DB where
	31	fmap fn (DB k) = DB (fmap fn . k)
	32
	33	instance Applicative DB where
	34	pure x = DB (\ _ -> pure x)
	35	DB fn <*> DB x =
	36	DB (\ c -> fn c <*> x c)
	37
	38	instance Monad DB where
	39	DB x >>= fn = DB $ \ c -> do
	40	x' <- x c
	41	runDB (fn x') c
	42
	43
	44	io :: IO a -> DB a
	45	io k = DB (\ _ -> k)
	46
	47	raise :: DBException -> DB a
	48	raise e = DB (\ _ -> Exn.throwIO e)
	49
	50	data Field where
	51	Field :: SQL.ToField r => r -> Field
	52
	53	instance SQL.ToField Field where
	54	toField (Field x) = SQL.toField x
	55
	56	f :: SQL.ToField r => r -> Field
	57	f = Field
	58
	59	query :: SQL.FromRow r => SQL.Query -> [Field] -> DB [r]
	60	query q [] = DB $ \conn -> SQL.query_ conn q
	61	query q as = DB $ \conn -> SQL.query conn q as
	62
	63	queryMb :: SQL.FromRow r => SQL.Query -> [Field] -> DB (Maybe r)
	64	queryMb q as = DB $ \conn -> do
	65	rs <- case as of
	66	[] -> SQL.query_ conn q
	67	_ -> SQL.query conn q as
	68	case rs of
	69	[] -> pure Nothing
	70	[x] -> pure (Just x)
	71	_ -> Exn.throwIO NonUniqueResult
	72
	73	queryOne :: (SQL.FromRow r) => SQL.Query -> [Field] -> DB r
	74	queryOne q as = DB $ \conn -> do
	75	rs <- case as of
	76	[] -> SQL.query_ conn q
	77	_ -> SQL.query conn q as
	78	case rs of
	79	[x] -> pure x
	80	_ -> Exn.throwIO NonUniqueResult
	81
	82	execute :: SQL.Query -> [Field] -> DB ()
	83	execute q as = DB $ \conn -> do
	84	case as of
	85	[] -> SQL.execute_ conn q
	86	_ -> SQL.execute conn q as
	87
	88	lastRow :: DB Int
	89	lastRow = DB $ \conn -> fromIntegral `fmap` SQL.lastInsertRowId conn

+128

-54

src/Inf/DB.hs less more

2	2
3	3	module Inf.DB where
4	4
5		import qualified Control.Exception as Exn
6		import qualified Database.SQLite.Simple as SQL
	5	import Control.Monad (forM)
7	6	import qualified Data.Text as T
8	7	import qualified Data.Time as Time
9		import Data.Typeable (Typeable)
10	8
	9	import qualified Inf.DB.Monad as DB
11	10	import Inf.Types
12	11
13
14		type DB r = SQL.Connection -> IO r
15
16		data DBException
17		= MissingPost PostId
18		deriving (Eq, Show, Typeable)
19
20		instance Exn.Exception DBException where
21
22		-- \| A utility function for grabbing the only relevant value from a
23		-- query
24		unique :: [SQL.Only a] -> Maybe a
25		unique (SQL.Only x:_) = Just x
26		unique _ = Nothing
27
28		submitPost :: User -> RawPost -> DB Bool
29		submitPost ~~uname rp c = case rpId rp of~~
	12	submitPost :: User -> RawPost -> DB.DB ()
	13	submitPost uname rp = case rpId rp of
30	14	Just (PostId n) \| uname == rpAuthor rp -> do
31		pure ()
32		SQL.execute c
	15	DB.execute
33	16	"UPDATE posts \
34	17	\ SET title = ?, author = ?, contents = ? \
35	18	\ WHERE id = ?"
36		(rpTitle rp, userName (rpAuthor rp), rpContents rp, n)
37		SQL.execute c
	19	[ DB.f (rpTitle rp), DB.f (userName (rpAuthor rp)), DB.f (rpContents rp), DB.f n]
	20	DB.execute
38	21	"UPDATE lookup SET slug = ? WHERE post_id = ?"
39		(slugify (rpTitle rp), n)
40		pure True
41
	22	[DB.f (slugify (rpTitle rp)), DB.f n]
	23	Just _ -> DB.raise DB.BadUserError
42	24	Nothing -> do
43		now <- Time.getCurrentTime
44		prev <- unique `fmap` SQL.query_ c
45		"SELECT id FROM posts ORDER BY time DESC LIMIT 1"
46		SQL.execute c
	25	now <- DB.io Time.getCurrentTime
	26	prev <- fmap (fmap DB.fromOnly) (DB.queryMb "SELECT id FROM posts ORDER BY time DESC LIMIT 1" [])
	27	DB.execute
47	28	"INSERT INTO posts \
48	29	\ (title, contents, author, time, next, prev) \
49	30	\ VALUES (?, ?, ?, ?, ?, ?)"
50		~~(rpTitle rp, rpContents rp, rpAuthor rp, now, Nothing :: Maybe Int, prev :: Maybe Int)~~
	31	[DB.f (rpTitle rp), DB.f (rpContents rp), DB.f (rpAuthor rp), DB.f now, DB.f (Nothing :: Maybe Int), DB.f (prev :: Maybe Int)]
51	32
52		new <- ~~SQL.lastInsertRowId c~~
	33	new <- DB.lastRow
53	34	case prev of
54		Just p -> SQL.execute c
55		"UPDATE posts SET next = ? WHERE id = ?" (new, p)
	35	Just p -> DB.execute
	36	"UPDATE posts SET next = ? WHERE id = ?" [DB.f new, DB.f p]
56	37	Nothing -> pure ()
57	38
58	39	let (year, month, _) = Time.toGregorian (Time.utctDay now)
59		~~SQL.execute c~~
	40	DB.execute
60	41	"INSERT INTO lookup (year, month, time, slug, post_id) \
61	42	\ VALUES (?, ?, ?, ?, ?)"
62		(year, month, now, slugify (rpTitle rp), new)
63		pure True
	43	[DB.f year, DB.f month, DB.f now, DB.f (slugify (rpTitle rp)), DB.f new]
64	44
65		_ -> pure False
66
67		deletePost :: RawPost -> DB Bool
68		deletePost rp c
	45	deletePost :: RawPost -> DB.DB ()
	46	deletePost rp
69	47	\| Just post <- rpId rp = do
70		vals <- SQL.query c
71		"SELECT next, prev FROM posts WHERE id = ?"
72		~~(SQL.Only post)~~
	48	vals <- DB.query "SELECT next, prev FROM posts WHERE id = ?" [DB.f post]
73	49
74	50	(oldNext :: Maybe Int, oldPrev :: Maybe Int) <- case vals of
75		[] -> ~~Exn.throwIO (~~MissingPost post)
	51	[] -> DB.raise (DB.MissingPost post)
76	52	(x, y):_ -> pure (x, y)
77	53
78	54	case oldPrev of
79		Just n -> SQL.execute c
80		"UPDATE posts SET next = ? WHERE id = ?" (oldNext, n)
	55	Just n -> DB.execute
	56	"UPDATE posts SET next = ? WHERE id = ?" [DB.f oldNext, DB.f n]
81	57	Nothing -> pure ()
82	58
83	59	case oldNext of
84		Just n -> SQL.execute c
85		"UPDATE posts SET prev = ? WHERE id = ?" (oldPrev, n)
	60	Just n -> DB.execute
	61	"UPDATE posts SET prev = ? WHERE id = ?" [DB.f oldPrev, DB.f n]
86	62	Nothing -> pure ()
87	63
88		SQL.execute c "DELETE FROM lookup WHERE post_id = ?" (SQL.Only post)
89		SQL.execute c "DELETE FROM posts WHERE id = ?" (SQL.Only post)
90		pure True
91		deletePost _ _ = pure False
	64	DB.execute "DELETE FROM lookup WHERE post_id = ?" [DB.f post]
	65	DB.execute "DELETE FROM posts WHERE id = ?" [DB.f post]
	66	deletePost _ = DB.raise DB.NoSuchPost
	67
	68
	69
	70	newestPost :: DB.DB (Maybe Post)
	71	newestPost = do
	72	values <- DB.queryMb "SELECT * FROM posts ORDER BY time DESC LIMIT 1" []
	73	forM values $ \(pId, title, contents, author, date, next, prev) -> do
	74	nextRef <- mapM postRefById next
	75	prevRef <- mapM postRefById prev
	76	pure Post
	77	{ postId = pId
	78	, postDate = date
	79	, postTitle = title
	80	, postContents = contents
	81	, postAuthor = author
	82	, postNext = nextRef
	83	, postPrev = prevRef
	84	}
	85
	86	postRefById :: PostId -> DB.DB PostRef
	87	postRefById pId = do
	88	(year, month, slug, name, date) <-
	89	DB.queryOne "SELECT l.year, l.month, l.slug, p.title, p.time \
	90	\ FROM lookup l, posts p \
	91	\ WHERE l.post_id = p.id and p.id = ?" [DB.f pId]
	92	pure PostRef
	93	{ prYear = year
	94	, prMonth = month
	95	, prSlug = slug
	96	, prName = name
	97	, prDate = date
	98	}
	99
	100
	101	newestPostRef :: DB.DB PostRef
	102	newestPostRef = do
	103	vals <- DB.queryOne "SELECT id FROM posts ORDER BY time DESC LIMIT 1" []
	104	postRefById (DB.fromOnly vals)
	105
	106	oldestPostRef :: DB.DB PostRef
	107	oldestPostRef = do
	108	vals <- DB.queryOne "SELECT id FROM posts ORDER BY time ASC LIMIT 1" []
	109	postRefById (DB.fromOnly vals)
	110
	111	staticPage :: T.Text -> DB.DB Page
	112	staticPage name = do
	113	pg <- DB.queryMb "SELECT title, contents FROM pages WHERE slug = ?"
	114	[DB.f name]
	115	case pg of
	116	Nothing -> DB.raise (DB.MissingPage name)
	117	Just x -> pure x
	118
	119	allPosts :: DB.DB [Post]
	120	allPosts = do
	121	values <- DB.query "SELECT id, time, title, contents, author FROM posts" []
	122	pure [ Post pId date title content author Nothing Nothing
	123	\| (pId, date, title, content, author) <- values
	124	]
	125
	126	allPostRefs :: DB.DB [PostRef]
	127	allPostRefs = do
	128	posts <- DB.query "SELECT l.year, l.month, l.slug, p.title, p.time \
	129	\ FROM lookup l, posts p WHERE p.id = l.post_id \
	130	\ ORDER BY p.time DESC" []
	131	pure [ PostRef
	132	{ prYear = year
	133	, prMonth = month
	134	, prSlug = slug
	135	, prName = title
	136	, prDate = date
	137	}
	138	\| (year, month, slug, title, date) <- posts
	139	]
	140
	141	postByDateAndSlug :: T.Text -> T.Text -> T.Text -> DB.DB Post
	142	postByDateAndSlug year month slug = do
	143	values <- DB.queryMb
	144	"SELECT post_id FROM lookup WHERE year = ? AND month = ? AND slug = ?"
	145	[DB.f year, DB.f month, DB.f slug]
	146	case values of
	147	Just p -> postById (DB.fromOnly p)
	148	Nothing -> DB.raise (DB.NoPostFound year month slug)
	149
	150	postById :: PostId -> DB.DB Post
	151	postById pId = do
	152	(title, contents, author, date, next, prev)
	153	<- DB.queryOne "SELECT title, contents, author, time, next, prev \
	154	\ FROM posts WHERE id = ?" [DB.f pId]
	155	nextRef <- mapM postRefById next
	156	prevRef <- mapM postRefById prev
	157	pure Post
	158	{ postId = pId
	159	, postDate = date
	160	, postTitle = title
	161	, postContents = contents
	162	, postAuthor = author
	163	, postNext = nextRef
	164	, postPrev = prevRef
	165	}

+68

-0

src/Inf/Feed.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Inf.Feed (renderFeed) where
	4
	5	import Control.Monad (forM)
	6	import qualified Data.ByteString.Lazy as LBS
	7	import qualified Text.Atom.Feed as Atom
	8	import qualified Text.Atom.Feed.Export as Atom
	9	import qualified Text.XML as XML
	10
	11	import qualified Inf.Templates as Template
	12	import Inf.Types
	13
	14	renderFeed :: [Post] -> IO LBS.ByteString
	15	renderFeed posts = do
	16	renderedPosts <- forM posts $ \p -> do
	17	content <- Template.markdown (postContents p)
	18	pure p { postContents = content }
	19	let Right el = XML.fromXMLElement (Atom.xmlFeed (mkFeed renderedPosts))
	20	doc = XML.Document (XML.Prologue [] Nothing []) el []
	21	pure (XML.renderLBS XML.def doc)
	22
	23	author :: Atom.Person
	24	author = Atom.Person
	25	{ Atom.personName = "Getty Ritter"
	26	, Atom.personURI = Just "https://gdritter.com/"
	27	, Atom.personEmail = Nothing
	28	, Atom.personOther = []
	29	}
	30
	31	mkFeed :: [Post] -> Atom.Feed
	32	mkFeed posts = let postsRev = reverse posts in Atom.Feed
	33	{ Atom.feedId = "https://blog.infinitenegativeutility.com/"
	34	, Atom.feedTitle = Atom.TextString "Infinite Negative Utility"
	35	, Atom.feedUpdated = postDateT (head postsRev)
	36	, Atom.feedAuthors = [author]
	37	, Atom.feedCategories = []
	38	, Atom.feedContributors = [author]
	39	, Atom.feedGenerator = Nothing
	40	, Atom.feedIcon = Nothing
	41	, Atom.feedLinks = []
	42	, Atom.feedLogo = Nothing
	43	, Atom.feedRights = Nothing
	44	, Atom.feedSubtitle = Nothing
	45	, Atom.feedEntries = map mkEntry postsRev
	46	, Atom.feedAttrs = []
	47	, Atom.feedOther = []
	48	}
	49
	50	mkEntry :: Post -> Atom.Entry
	51	mkEntry p = Atom.Entry
	52	{ Atom.entryId = postURL p
	53	, Atom.entryTitle = Atom.TextString (postTitle p)
	54	, Atom.entryUpdated = (postDateT p)
	55	, Atom.entryAuthors = [author]
	56	, Atom.entryCategories = []
	57	, Atom.entryContent = Just (Atom.HTMLContent (postContents p))
	58	, Atom.entryContributor = [author]
	59	, Atom.entryLinks = [ Atom.nullLink (postURL p) ]
	60	, Atom.entryPublished = Just (postDateT p)
	61	, Atom.entryRights = Nothing
	62	, Atom.entrySource = Nothing
	63	, Atom.entrySummary = Nothing
	64	, Atom.entryInReplyTo = Nothing
	65	, Atom.entryInReplyTotal = Nothing
	66	, Atom.entryAttrs = []
	67	, Atom.entryOther = []
	68	}

+96

-0

src/Inf/Templates.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Inf.Templates
	4	( main
	5	, page
	6	, list
	7
	8	, dbException
	9	, someException
	10
	11	, markdown
	12	) where
	13
	14	import qualified Control.Exception as Exn
	15	import Control.Monad ((=<<))
	16	import Data.Aeson ((.=))
	17	import qualified Data.Aeson as Aeson
	18	import qualified Data.Text as TS
	19	import qualified Data.Text.Lazy as T
	20	import qualified Text.Mustache as Stache
	21	import qualified Text.Pandoc.Class as Pandoc
	22	import qualified Text.Pandoc.Extensions as Pandoc
	23	import qualified Text.Pandoc.Highlighting as Pandoc
	24	import qualified Text.Pandoc.Options as Pandoc
	25	import qualified Text.Pandoc.Readers.Markdown as Pandoc
	26	import qualified Text.Pandoc.Writers.HTML as Pandoc
	27
	28	import Inf.Types
	29
	30	markdownOpts :: Pandoc.ReaderOptions
	31	markdownOpts = Pandoc.def
	32	{ Pandoc.readerExtensions = Pandoc.pandocExtensions
	33	}
	34
	35	htmlOpts :: Pandoc.WriterOptions
	36	htmlOpts = Pandoc.def
	37	{ Pandoc.writerHighlightStyle = Just Pandoc.tango
	38	}
	39
	40	markdown :: TS.Text -> IO TS.Text
	41	markdown raw = Pandoc.runIOorExplode $ do
	42	pandoc <- Pandoc.readMarkdown markdownOpts raw
	43	Pandoc.writeHtml5String htmlOpts pandoc
	44
	45	main :: T.Text -> T.Text -> IO T.Text
	46	main title contents = do
	47	template <- Stache.compileMustacheFile "templates/main.mustache"
	48	let vals = Aeson.object
	49	[ "title" .= title
	50	, "contents" .= contents
	51	]
	52	pure (Stache.renderMustache template vals)
	53
	54	page :: TS.Text -> IO T.Text
	55	page contents = do
	56	template <- Stache.compileMustacheFile "templates/page.mustache"
	57	mk <- markdown contents
	58	let vals = Aeson.object
	59	[ "contents" .= mk ]
	60	pure (Stache.renderMustache template vals)
	61
	62	list :: [PostRef] -> IO T.Text
	63	list posts = do
	64	template <- Stache.compileMustacheFile "templates/list.mustache"
	65	let vals = Aeson.object
	66	[ "posts" .=
	67	[ Aeson.object [ "url" .= postRefURL ref
	68	, "title" .= prName ref
	69	, "date" .= postRefDateT ref
	70	]
	71	\| ref <- posts
	72	]
	73	]
	74	pure (Stache.renderMustache template vals)
	75
	76
	77	dbException :: DBException -> IO T.Text
	78	dbException exn = main "Error" =<< page (TS.unlines
	79	( "## Internal server error"
	80	: case exn of
	81	NoSuchPost -> [ "database misconfiguration" ]
	82	BadUserError -> [ "bad user session" ]
	83	NonUniqueResult -> [ "database misconfiguration" ]
	84	MissingPost pId -> [ "missing post: `" <> TS.pack (show pId) <> "`"]
	85	MissingPage name -> [ "missing page: `" <> name <> "`"]
	86	NoPostFound year month slug ->
	87	[ "no such post: `" <> year <> "/" <> month <> "/" <> slug <> "`" ]
	88	))
	89
	90	someException :: Exn.SomeException -> IO T.Text
	91	someException exn = main "Internal Sever Error" =<< page (TS.unlines
	92	[ "The following unexpected error occurred:"
	93	, "```"
	94	, TS.pack (show exn)
	95	, "```"
	96	])

+28

-0

src/Inf/Types.hs less more

2	2
3	3	module Inf.Types where
4	4
	5	import qualified Control.Exception as Exn
5	6	import qualified Data.Char as Char
6	7	import qualified Data.Text as T
7	8	import qualified Data.Time as Time

67	68	, rpContents = ""
68	69	}
69	70
	71	data Page = Page
	72	{ pageName :: T.Text
	73	, pageText :: T.Text
	74	} deriving Show
	75
	76	instance SQL.FromRow Page where
	77	fromRow = uncurry Page <$> SQL.fromRow
70	78
71	79	data URL = URL
72	80	{ urlRelative :: T.Text

100	108	]
101	109
102	110
	111	postRefDateT :: PostRef -> T.Text
	112	postRefDateT PostRef { prDate = date } =
	113	T.pack (Time.formatTime
	114	Time.defaultTimeLocale
	115	Time.rfc822DateFormat
	116	date)
	117
103	118	postRefURL :: PostRef -> T.Text
104	119	postRefURL PostRef { prYear = year, prMonth = month, prSlug = slug } =
105	120	T.concat [ "/", T.pack (show year)

123	138	, rpContents = postContents p
124	139	, rpAuthor = postAuthor p
125	140	}
	141
	142
	143
	144	data DBException
	145	= MissingPost PostId
	146	\| MissingPage T.Text
	147	\| NoPostFound T.Text T.Text T.Text
	148	\| NonUniqueResult
	149	\| BadUserError
	150	\| NoSuchPost
	151	deriving (Eq, Show)
	152
	153	instance Exn.Exception DBException where

+89

-14

src/Main.hs less more

2	2
3	3	module Main where
4	4
5		import qualified ~~Data.Text as T~~
	5	import qualified Control.Exception as Exn
	6	import Control.Monad ((>=>))
	7	import qualified Data.Text as TS
	8	import qualified Data.Text.Encoding as EncodingS
	9	import qualified Data.Text.Lazy as T
	10	import qualified Data.Text.Lazy.Encoding as Encoding
	11	import qualified Network.HTTP.Types as HTTP
6	12	import qualified Network.Wai as W
7	13	import qualified Network.Wai.Handler.Warp as W
	14	import System.FilePath ((</>))
8	15	import qualified System.Environment as Env
9	16	import qualified Text.Read as Read
	17
	18	import qualified Inf.DB.Monad as DB
	19	import qualified Inf.DB as DB
	20	import qualified Inf.Feed as Feed
	21	import qualified Inf.Templates as Template
	22	import Inf.Types
10	23
11	24	main :: IO ()
12	25	main = do

15	28	Just x
16	29	\| Just p <- Read.readMaybe x -> p
17	30	_ -> 8080
18		~~W.run port (\ r k -> route r >>= k)~~
	31	conn <- DB.open "test.db"
	32	W.run port $ \ r k -> do
	33	resp <- route conn r
	34	`Exn.catch` (Template.dbException >=> raise500)
	35	`Exn.catch` (Template.someException >=> raise500)
	36	k resp
19	37
	38	page :: T.Text -> T.Text -> IO W.Response
	39	page title stuff = do
	40	pg <- Template.main title stuff
	41	let headers = [(HTTP.hContentType, "text/html")]
	42	pure (W.responseLBS HTTP.status200 [] (Encoding.encodeUtf8 pg))
20	43
21		raise404 :: [T.Text] -> IO W.Response
22		raise404 = undefined
	44	raise404 :: [TS.Text] -> IO W.Response
	45	raise404 msgs = do
	46	contents <- Template.page $ TS.unwords
	47	[ "No handler found for page "
	48	, "`/" <> TS.intercalate "/" msgs <> "`"
	49	]
	50	pg <- Template.main "404" contents
	51	pure (W.responseLBS HTTP.status404 [] (Encoding.encodeUtf8 pg))
23	52
	53	raise500 :: T.Text -> IO W.Response
	54	raise500 msgs =
	55	let body = Encoding.encodeUtf8 msgs
	56	in pure (W.responseLBS HTTP.status500 [] body)
24	57
25		route :: W.Request -> IO W.Response
26		route req = case (W.requestMethod req, W.pathInfo req) of
27		("GET", []) -> undefined
	58	route :: DB.Connection -> W.Request -> IO W.Response
	59	route c req = case (W.requestMethod req, W.pathInfo req) of
	60	("GET", []) -> do
	61	post <- DB.runDB DB.newestPostRef c
	62	let headers = [(HTTP.hLocation, EncodingS.encodeUtf8 (postRefURL post))]
	63	pure (W.responseLBS HTTP.status307 headers "redirecting...")
	64
28	65	("POST", []) -> undefined
	66
29	67	("GET", ["auth"]) -> undefined
30		("GET", ["archive"]) -> undefined
	68
	69	("GET", ["archive"]) -> do
	70	posts <- DB.runDB DB.allPostRefs c
	71	contents <- Template.list posts
	72	page "Past Entries" contents
	73
31	74	("GET", ["create"]) -> undefined
32		("GET", [y, m, s]) -> undefined
	75
	76	("GET", [y, m, s]) -> do
	77	post <- DB.runDB (DB.postByDateAndSlug y m s) c
	78	contents <- Template.page (postContents post)
	79	page (T.fromStrict (postTitle post)) contents
	80
33	81	("POST", [y, m, s]) -> undefined
	82
34	83	("GET", [y, m, s, "edit"]) -> undefined
	84
35	85	("GET", [y, m, s, "delete"]) -> undefined
	86
36	87	("GET", ["login"]) -> undefined
	88
37	89	("GET", ["logout"]) -> undefined
38		("GET", ["oldest"]) -> undefined
39		("GET", ["static", fp]) -> undefined
40		("GET", ["rss"]) -> undefined
41		("GET", [page]) -> undefined
	90
	91	("GET", ["newest"]) -> do
	92	post <- DB.runDB DB.newestPostRef c
	93	let headers = [(HTTP.hLocation, EncodingS.encodeUtf8 (postRefURL post))]
	94	pure (W.responseLBS HTTP.status307 headers "redirecting...")
	95
	96	("GET", ["oldest"]) -> do
	97	post <- DB.runDB DB.oldestPostRef c
	98	let headers = [(HTTP.hLocation, EncodingS.encodeUtf8 (postRefURL post))]
	99	pure (W.responseLBS HTTP.status307 headers "redirecting...")
	100
	101	("GET", ["static", fp]) ->
	102	let path = "static" </> TS.unpack fp
	103	in pure (W.responseFile HTTP.status200 [] path Nothing)
	104
	105	("GET", ["rss"]) -> do
	106	posts <- DB.runDB DB.allPosts c
	107	feed <- Feed.renderFeed posts
	108	let headers =
	109	[(HTTP.hContentType, "application/atom+xml")]
	110	pure (W.responseLBS HTTP.status200 headers feed)
	111
	112	("GET", [pagename]) -> do
	113	pg <- DB.runDB (DB.staticPage pagename) c
	114	contents <- Template.page (pageText pg)
	115	page (T.fromStrict pagename) contents
	116
42	117	("GET", [page, "edit"]) -> undefined
	118
43	119	(_, path) -> raise404 path
44

+60

-0

static/highlighting.css less more

	1	a.sourceLine { display: inline-block; line-height: 1.25; }
	2	a.sourceLine { pointer-events: none; color: inherit; text-decoration: inherit; }
	3	a.sourceLine:empty { height: 1.2em; }
	4	.sourceCode { overflow: visible; }
	5	code.sourceCode { white-space: pre; position: relative; }
	6	div.sourceCode { margin: 1em 0; }
	7	pre.sourceCode { margin: 0; }
	8	@media screen {
	9	div.sourceCode { overflow: auto; }
	10	}
	11	@media print {
	12	code.sourceCode { white-space: pre-wrap; }
	13	a.sourceLine { text-indent: -1em; padding-left: 1em; }
	14	}
	15	pre.numberSource a.sourceLine
	16	{ position: relative; left: -4em; }
	17	pre.numberSource a.sourceLine::before
	18	{ content: attr(title);
	19	position: relative; left: -1em; text-align: right; vertical-align: baseline;
	20	border: none; pointer-events: all; display: inline-block;
	21	-webkit-touch-callout: none; -webkit-user-select: none;
	22	-khtml-user-select: none; -moz-user-select: none;
	23	-ms-user-select: none; user-select: none;
	24	padding: 0 4px; width: 4em;
	25	color: #aaaaaa;
	26	}
	27	pre.numberSource { margin-left: 3em; border-left: 1px solid #aaaaaa; padding-left: 4px; }
	28	div.sourceCode
	29	{ background-color: #f8f8f8; }
	30	@media screen {
	31	a.sourceLine::before { text-decoration: underline; }
	32	}
	33	code span.al { color: #ef2929; } /* Alert */
	34	code span.an { color: #8f5902; font-weight: bold; font-style: italic; } /* Annotation */
	35	code span.at { color: #c4a000; } /* Attribute */
	36	code span.bn { color: #0000cf; } /* BaseN */
	37	code span.cf { color: #204a87; font-weight: bold; } /* ControlFlow */
	38	code span.ch { color: #4e9a06; } /* Char */
	39	code span.cn { color: #000000; } /* Constant */
	40	code span.co { color: #8f5902; font-style: italic; } /* Comment */
	41	code span.cv { color: #8f5902; font-weight: bold; font-style: italic; } /* CommentVar */
	42	code span.do { color: #8f5902; font-weight: bold; font-style: italic; } /* Documentation */
	43	code span.dt { color: #204a87; } /* DataType */
	44	code span.dv { color: #0000cf; } /* DecVal */
	45	code span.er { color: #a40000; font-weight: bold; } /* Error */
	46	code span.ex { } /* Extension */
	47	code span.fl { color: #0000cf; } /* Float */
	48	code span.fu { color: #000000; } /* Function */
	49	code span.im { } /* Import */
	50	code span.in { color: #8f5902; font-weight: bold; font-style: italic; } /* Information */
	51	code span.kw { color: #204a87; font-weight: bold; } /* Keyword */
	52	code span.op { color: #ce5c00; font-weight: bold; } /* Operator */
	53	code span.ot { color: #8f5902; } /* Other */
	54	code span.pp { color: #8f5902; font-style: italic; } /* Preprocessor */
	55	code span.sc { color: #000000; } /* SpecialChar */
	56	code span.ss { color: #4e9a06; } /* SpecialString */
	57	code span.st { color: #4e9a06; } /* String */
	58	code span.va { color: #000000; } /* Variable */
	59	code span.vs { color: #4e9a06; } /* VerbatimString */
	60	code span.wa { color: #8f5902; font-weight: bold; font-style: italic; } /* Warning */

+149

-0

static/main.css less more

	1	body {
	2	font-family: "Arial", "Helvetica", sans-serif;
	3	margin-left: 0px;
	4	margin-right: 0px;
	5	background-color: #FFFFFF;
	6	color: #222222;
	7	font-size: large;
	8	}
	9
	10	a:link { color: #bbbbbb; }
	11	a:hover { color: #bbbbbb; }
	12	a:active { color: #999999; }
	13	a:visited { color: #999999; }
	14
	15	.username {
	16	width: 100%;
	17	padding-top: 5px;
	18	padding-bottom: 5px;
	19	background-color: rgba(178,32,27,0.95);
	20	color: #FFFFFF;
	21	text-align: center;
	22	margin-bottom: 10px;
	23	}
	24
	25	.title {
	26	width: 100%;
	27	text-align: center;
	28	padding: 1px;
	29	background-color: #222222;
	30	color: #FFFFFF;
	31	margin-bottom: 20px;
	32	}
	33
	34	.nav {
	35	width: 100%;
	36	background-color: #444444;
	37	padding-top: 12px;
	38	padding-bottom: 12px;
	39	margin: 0 auto;
	40	margin-bottom: 10px;
	41	text-align: center;
	42	color: #FFFFFF;
	43	}
	44
	45	.navitem {
	46	padding-left: 100px;
	47	padding-top: 10px;
	48	padding-right: 100px;
	49	padding-bottom: 10px
	50	}
	51
	52	.navitem a {
	53	color: #FFFFFF;
	54	}
	55
	56	.navitem a visited {
	57	color: #FFFFFF;
	58	}
	59
	60	.postbody {
	61	width: 60%;
	62	margin-left: auto;
	63	margin-right: auto;
	64	background-color: #FFFFFF;
	65	padding-left: 20px;
	66	padding-right: 20px;
	67	padding-top: 10px;
	68	padding-bottom: 30px;
	69	}
	70
	71	.list {
	72	width: 60%;
	73	margin-left: auto;
	74	margin-right: auto;
	75	background-color: #FFFFFF;
	76	padding-left: 20px;
	77	padding-right: 20px;
	78	padding-top: 10px;
	79	padding-bottom: 30px;
	80	}
	81
	82	.main h1 {
	83	color: #FFFFFF;
	84	background-color: #888888;
	85	text-align: center;
	86	padding: 10px;
	87	-moz-border-radius: 15px;
	88	border-radius: 15px;
	89	}
	90
	91	.main h2 {
	92	color: #FFFFFF;
	93	background-color: #888888;
	94	text-align: center;
	95	padding: 10px;
	96	-moz-border-radius: 15px;
	97	border-radius: 15px;
	98	}
	99
	100	.main h3 {
	101	color: #FFFFFF;
	102	background-color: #888888;
	103	text-align: center;
	104	padding: 10px;
	105	-moz-border-radius: 15px;
	106	border-radius: 15px;
	107	}
	108
	109	.edit {
	110	text-align: center;
	111	}
	112
	113	.editlink {
	114	text-align: center;
	115	}
	116
	117	.author {
	118	font-style: italic;
	119	text-align: center;
	120	background-color: rgba(176,189,140,0.2);
	121	padding: 10px;
	122	width: 60%;
	123	margin-left: auto;
	124	margin-right: auto;
	125	}
	126
	127	.new {
	128	display: inline-block;
	129	width: 50%;
	130	text-align: left;
	131	}
	132
	133	.old {
	134	display: inline-block;
	135	width: 50%;
	136	text-align: right;
	137	}
	138
	139	pre {
	140	padding: 10px;
	141	-moz-border-radius: 15px;
	142	border-radius: 15px;
	143	padding-left: 30px;
	144	padding-right: 30px;
	145	}
	146
	147	code {
	148	padding: 2px;
	149	}⏎

+9

-0

templates/delete.mustache less more

	1	<div class="edit">
	2	<p>Are you sure you want to delete this post?</p>
	3	<p>
	4	<a href="{{post_url}}">No</a>
	5	<form name="delpost" action="{{post_url}}" method="DELETE">
	6	<input type="submit" value="yes" />
	7	</form>
	8	</p>
	9	</div>

+10

-0

templates/edit.mustache less more

	1	<div class="edit">
	2	<form name="newpost" action="/" method="POST"
	3	enctype="application/x-www-form-urlencoded;charset=UTF-8">
	4	<input type="hidden" name="id" value="{{id}}"/>
	5	<input type="text" name="title" value="{{title}}"/>
	6	<input type="hidden" name="author" value="{{author}}"/><br/>
	7	<textarea cols="80" rows="40" name="contents">{{contents}}</textarea><br/>
	8	<input type="submit"/>
	9	</form>
	10	</div>

+5

-0

templates/list.mustache less more

	1	<div class="list">
	2	{{#posts}}
	3	<p><a href={{url}}>{{title}}</a> <span class="date">on {{date}}</span></p>
	4	{{/posts}}
	5	</div>

+6

-0

templates/login.mustache less more

	1	<form name="login" action="/login" method="POST"
	2	enctype="application/x-www-form-urlencoded;charset=UTF-8">
	3	<input type="text" name="user"/><br/>
	4	<input type="password" name="passwd"/><br/>
	5	<input type="submit"/>
	6	</form>

+38

-0

templates/main.mustache less more

	1	<!DOCTYPE html>
	2	<html>
	3	<head>
	4	<meta charset="utf-8" />
	5	<link rel="stylesheet" type="text/css" href="/static/main.css" />
	6	<link rel="stylesheet" type="text/css" href="/static/highlighting.css" />
	7	<link rel="alternate" type="application/rss+xml"
	8	title="Infinite Negative Utility"
	9	href="/rss" />
	10	<title>{{title}} — Infinite Negative Utility</title>
	11	</head>
	12	<body>
	13	{{#user}}
	14	<div class="username">
	15	Logged in as {{name}}
	16	—
	17	<a href="/create">Create a Post</a>
	18	—
	19	<a href="/change">Change My Password</a>
	20	—
	21	<a href="/logout">Log Out</a>
	22	</div>
	23	{{/user}}
	24	<div class="title">
	25	<h1>{{title}}</h1>
	26	</div>
	27	<div class="nav">
	28	<a class="navitem" href="/newest">Newest</a>
	29	<a class="navitem" href="/archive">Archive</a>
	30	<a class="navitem" href="/oldest">Oldest</a>
	31	<a class="navitem" href="/about">About</a>
	32	</div>
	33	<div class="main">
	34	{{{ contents }}}
	35	</div>
	36	<div class="nav">©2018 Getty Ritter</div>
	37	</body>
	38	</html>

+5

-0

templates/page.mustache less more

	1	<div class="post" >
	2	<div class="postbody">
	3	{{{ contents }}}
	4	</div>
	5	</div>

+11

-0

templates/password.mustache less more

	1	{{#user}}
	2	<form name="passwd" action="/change" method="POST"
	3	enctype="application/x-www-form-urlencoded;charset=UTF-8">
	4	Old password for {{name}}:<br/>
	5	<input type="password" name="oldpasswd"/><br/>
	6	New password:<br/>
	7	<input type="password" name="p1"/><br/>
	8	<input type="password" name="p2"/><br/>
	9	<input type="submit"/>
	10	</form>
	11	{{/user}}

+11

-0

templates/post.mustache less more

	1	<div class="postbody">
	2
	3	</div>
	4	<div class="new">
	5	{{#next}}
	6	{{/next}}
	7	</div>
	8	<div class="old">
	9	{{#prev}}
	10	{{/prev}}
	11	</div>