Commit master - new-inf-blog

Start doing OpenGraph preview stuff Getty Ritter 5 years ago

4 changed file(s) with 84 addition(s) and 39 deletion(s). Collapse all Expand all

+52

-26

src/Inf/Templates.hs less more

1	1	{-# LANGUAGE OverloadedStrings #-}
	2	{-# LANGUAGE NamedFieldPuns #-}
2	3
3	4	module Inf.Templates
4	5	( main

8	9	, edit
9	10	, post
10	11	, delete
	12	, Main(..)
11	13
12	14	, dbException
13	15	, someException

18	20	) where
19	21
20	22	import qualified Control.Exception as Exn
21		import Control.Monad ((=<<))
22	23	import Data.Aeson ((.=))
23	24	import qualified Data.Aeson as Aeson
24	25	import Data.Monoid ((<>))

47	48	loggedError = show
48	49
49	50	instance InternalError Unimplemented where
50		renderedError (Unimplemented _) =
51		main Nothing "Unimplemented" =<<
52		~~page "IMPLEMENT ME"~~
	51	renderedError (Unimplemented _) = main Main
	52	{ mainUser = Nothing
	53	, mainTitle = "Unimplemented"
	54	, mainContents = "IMPLEMENT ME"
	55	, mainUrl = "/"
	56	}
53	57
54	58	loggedError (Unimplemented msg) = "Unimplemented: " ++ msg
55	59

68	72	pandoc <- Pandoc.readMarkdown markdownOpts raw
69	73	Pandoc.writeHtml5String htmlOpts pandoc
70	74
71		main :: Maybe TS.Text -> T.Text -> T.Text -> IO T.Text
72		main user title contents = do
	75	data Main = Main
	76	{ mainUser :: !(Maybe TS.Text)
	77	, mainTitle :: !T.Text
	78	, mainContents :: !T.Text
	79	, mainUrl :: !TS.Text
	80	}
	81
	82	main :: Main -> IO T.Text
	83	main Main { mainUser, mainTitle, mainContents, mainUrl } = do
73	84	template <- Stache.compileMustacheFile "templates/main.mustache"
74	85	let vals = Aeson.object
75		[ "title" .= title
76		, "contents" .= contents
77		~~, "user" .= case user of~~
	86	[ "title" .= mainTitle
	87	, "contents" .= mainContents
	88	, "user" .= case mainUser of
78	89	Nothing -> Aeson.toJSON ()
79	90	Just u -> Aeson.object [ "name" .= u ]
	91	, "url" .= mainUrl
80	92	]
81	93	pure (Stache.renderMustache template vals)
82	94

150	162
151	163
152	164	dbException :: DBException -> IO T.Text
153		dbException exn = main Nothing "Error" =<< page (TS.unlines
154		( "## Internal server error"
155		: case exn of
156		NoSuchPost -> [ "database misconfiguration" ]
157		BadUserError -> [ "bad user session" ]
158		NonUniqueResult -> [ "database misconfiguration" ]
159		MissingPost pId -> [ "missing post: `" <> TS.pack (show pId) <> "`"]
160		MissingPage name -> [ "missing page: `" <> name <> "`"]
161		NoPostFound year month slug ->
162		[ "no such post: `" <> year <> "/" <> month <> "/" <> slug <> "`" ]
163		))
	165	dbException exn = do
	166	contents <- page $ TS.unlines
	167	( "## Internal server error"
	168	: case exn of
	169	NoSuchPost -> [ "database misconfiguration" ]
	170	BadUserError -> [ "bad user session" ]
	171	NonUniqueResult -> [ "database misconfiguration" ]
	172	MissingPost pId -> [ "missing post: `" <> TS.pack (show pId) <> "`"]
	173	MissingPage name -> [ "missing page: `" <> name <> "`"]
	174	NoPostFound year month slug ->
	175	[ "no such post: `" <> year <> "/" <> month <> "/" <> slug <> "`" ]
	176	)
	177	main Main
	178	{ mainUser = Nothing
	179	, mainTitle = "Error"
	180	, mainContents = contents
	181	, mainUrl = "/"
	182	}
164	183
165	184	someException :: Exn.SomeException -> IO T.Text
166		someException exn = main Nothing "Internal Sever Error" =<< page (TS.unlines
167		[ "The following unexpected error occurred:"
168		, "```"
169		, TS.pack (show exn)
170		, "```"
171		])
	185	someException exn = do
	186	contents <- page $ TS.unlines
	187	[ "The following unexpected error occurred:"
	188	, "```"
	189	, TS.pack (show exn)
	190	, "```"
	191	]
	192	main Main
	193	{ mainUser = Nothing
	194	, mainTitle = "Internal Server Error"
	195	, mainContents = contents
	196	, mainUrl = "/"
	197	}

+14

-4

src/Inf/Web.hs less more

65	65	`Exn.catch` (\ (e :: Exn.SomeException) -> raise500 r e)
66	66	k resp
67	67
68		ok :: Maybe TS.Text -> T.Text -> T.Text -> IO W.Response
69		ok user title stuff = do
70		pg <- Template.main user title stuff
	68	ok :: Maybe TS.Text -> T.Text -> T.Text -> TS.Text -> IO W.Response
	69	ok user title stuff url = do
	70	pg <- Template.main Template.Main
	71	{ Template.mainUser = user
	72	, Template.mainTitle = title
	73	, Template.mainContents = stuff
	74	, Template.mainUrl = url
	75	}
71	76	let headers = [(HTTP.hContentType, "text/html")]
72	77	pure (W.responseLBS HTTP.status200 headers (Encoding.encodeUtf8 pg))
73	78

80	85	[ "No handler found for page "
81	86	, "`/" <> TS.intercalate "/" msgs <> "`"
82	87	]
83		pg <- Template.main ~~Nothing "404" contents~~
	88	pg <- Template.main Template.Main
	89	{ Template.mainUser = Nothing
	90	, Template.mainTitle ="404"
	91	, Template.mainContents = contents
	92	, Template.mainUrl = "/"
	93	}
84	94	pure (W.responseLBS HTTP.status404 [] (Encoding.encodeUtf8 pg))
85	95
86	96	raise500 :: Template.InternalError e => W.Request -> e -> IO W.Response

-9

src/Main.hs less more

56	56
57	57	("GET", ["auth"]) -> do
58	58	password <- Template.login
59		Web.ok user "login" password
	59	Web.ok user "login" password "/"
60	60
61	61	("GET", ["archive"]) -> do
62	62	posts <- DB.runDB c DB.allPostRefs
63	63	contents <- Template.list posts
64		Web.ok user "Past Entries" contents
	64	Web.ok user "Past Entries" contents "/archive"
65	65
66	66	("GET", ["create"]) ->
67	67	case user of
68	68	Nothing -> Web.redirect "/"
69	69	Just _ -> do
70	70	contents <- Template.edit "/" emptyRawPost
71		Web.ok user "New Post" contents
	71	Web.ok user "New Post" contents "/"
72	72
73	73	("GET", [y, m, s]) -> do
74	74	(post, cached) <- DB.runDB c $ do

77	77	pure (ps, ch)
78	78	case cached of
79	79	Just cache -> do
80		Web.ok user (T.fromStrict (postTitle post)) cache
	80	Web.ok user (T.fromStrict (postTitle post)) cache (postURL post)
81	81	Nothing -> do
82	82	contents <- Template.post user post
83	83	DB.runDB c (DB.storeCachedMarkup (postId post) contents)
84		Web.ok user (T.fromStrict (postTitle post)) contents
	84	Web.ok user (T.fromStrict (postTitle post)) contents (postURL post)
85	85
86	86	("POST", [y, m, s]) ->
87	87	case user of

116	116	Just {} -> do
117	117	oldPost <- DB.runDB c (DB.postByDateAndSlug y m s)
118	118	contents <- Template.edit (postURL oldPost) (postToRawPost oldPost)
119		Web.ok user (T.fromStrict (postTitle oldPost)) contents
	119	Web.ok user (T.fromStrict (postTitle oldPost)) contents "/"
120	120
121	121	("POST", [y, m, s, "delete"]) ->
122	122	case user of

134	134	Just _ -> do
135	135	post <- DB.runDB c (DB.postByDateAndSlug y m s)
136	136	contents <- Template.delete post
137		Web.ok user "Delete Post?" contents
	137	Web.ok user "Delete Post?" contents "/"
138	138
139	139	("POST", ["login"]) -> do
140	140	formData <- Web.formData req

181	181	("GET", [pagename]) -> do
182	182	pg <- DB.runDB c (DB.staticPage pagename)
183	183	contents <- Template.page (pageText pg)
184		Web.ok user (T.fromStrict pagename) contents
	184	Web.ok user (T.fromStrict pagename) contents ("/" <> pagename)
185	185
186	186	("GET", [_page, "edit"]) ->
187	187	case user of
188	188	Nothing -> Web.redirect "/"
189	189	Just _ -> do
190	190	contents <- Template.edit "/" emptyRawPost
191		Web.ok user "New Post" contents
	191	Web.ok user "New Post" contents "/"
192	192
193	193	(_, path) -> Web.raise404 req path

-0

templates/main.mustache less more

9	9	<link rel="alternate" type="application/rss+xml"
10	10	title="Infinite Negative Utility"
11	11	href="/rss" />
	12
	13	<meta property="og:title" content=""/>
	14	<meta property="og:url" content="{{url}}"/>
	15	<meta property="og:image" content="/static/inf-icon-128x128.png"/>
	16	<meta property="og:type" content="website"/>
	17	<meta property="og:description" content="{{title}}"/>
	18	<meta property="og:image:width" content="128"/>
	19	<meta property="og:image:height" content="128"/>
	20	<meta property="og:site_name" content="Infinite Negative Utility"/>
12	21	<title>{{title}} — Infinite Negative Utility</title>
13	22	</head>
14	23	<body>