Commit 4ea169fb932b657e03cf0c0dd57949c513341905 - new-inf-blog

+3

-0

new-inf-blog.cabal less more

18	18	Inf.DB
19	19	Inf.DB.Monad
20	20	Inf.Feed
	21	Inf.Log
21	22	Inf.Web
	23	Inf.Web.Cookies
22	24	default-language: Haskell2010
23	25	default-extensions: ScopedTypeVariables
24	26	ghc-options: -Wall

38	40	, xml-conduit
39	41	, bytestring
40	42	, pwstore-fast
	43	, unix⏎

+31

-13

src/Inf/DB.hs less more

3	3	module Inf.DB where
4	4
5	5	import Control.Monad (forM)
	6	import qualified Data.ByteString as BS
6	7	import qualified Data.Text as T
7	8	import qualified Data.Time as Time
8	9

11	12
12	13	submitPost :: User -> RawPost -> DB.DB ()
13	14	submitPost uname rp = case rpId rp of
14		Just (PostId n) \| uname == rpAuthor rp -> do
	15	Just (PostId n) \| uname == rpAuthor rp ->
15	16	DB.execute
16	17	"UPDATE posts \
17	18	\ SET title = ?, author = ?, contents = ? \
18	19	\ WHERE id = ?"
19		[ DB.f (rpTitle rp), DB.f (userName (rpAuthor rp)), DB.f (rpContents rp), DB.f n]
20		DB.execute
21		"UPDATE lookup SET slug = ? WHERE post_id = ?"
22		[DB.f (slugify (rpTitle rp)), DB.f n]
	20	[ DB.f (rpTitle rp)
	21	, DB.f (userName (rpAuthor rp))
	22	, DB.f (rpContents rp)
	23	, DB.f n
	24	]
23	25	Just _ -> DB.raise DB.BadUserError
24	26	Nothing -> do
25	27	now <- DB.io Time.getCurrentTime

69	71
70	72	newestPost :: DB.DB (Maybe Post)
71	73	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	values <- DB.queryMb
	75	"SELECT p.title, p.contents, p.author, p.time, p.next, p.prev, l.slug \
	76	\ FROM posts p, lookup l WHERE p.id == l.post_id ORDER BY time DESC LIMIT 1"
	77	[]
	78	forM values $ \(pId, title, contents, author, date, next, prev, slug) -> do
74	79	nextRef <- mapM postRefById next
75	80	prevRef <- mapM postRefById prev
76	81	pure Post
77	82	{ postId = pId
78	83	, postDate = date
79	84	, postTitle = title
	85	, postSlug = slug
80	86	, postContents = contents
81	87	, postAuthor = author
82	88	, postNext = nextRef

118	124
119	125	allPosts :: DB.DB [Post]
120	126	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~~
	127	values <- DB.query
	128	"SELECT p.id, p.time, p.title, p.contents, p.author, l.slug \
	129	\ FROM posts p, lookup l WHERE p.id == l.post_id " []
	130	pure [ Post pId date title slug content author Nothing Nothing
	131	\| (pId, date, title, content, author, slug) <- values
124	132	]
125	133
126	134	allPostRefs :: DB.DB [PostRef]

138	146	\| (year, month, slug, title, date) <- posts
139	147	]
140	148
	149
141	150	postByDateAndSlug :: T.Text -> T.Text -> T.Text -> DB.DB Post
142	151	postByDateAndSlug year month slug = do
143	152	values <- DB.queryMb

149	158
150	159	postById :: PostId -> DB.DB Post
151	160	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]~~
	161	(title, contents, author, date, next, prev, slug)
	162	<- DB.queryOne
	163	"SELECT p.title, p.contents, p.author, p.time, p.next, p.prev, l.slug \
	164	\ FROM posts p, lookup l WHERE p.id = l.post_id AND p.id = ?" [DB.f pId]
155	165	nextRef <- mapM postRefById next
156	166	prevRef <- mapM postRefById prev
157	167	pure Post
158	168	{ postId = pId
159	169	, postDate = date
160	170	, postTitle = title
	171	, postSlug = slug
161	172	, postContents = contents
162	173	, postAuthor = author
163	174	, postNext = nextRef
164	175	, postPrev = prevRef
165	176	}
	177
	178
	179	userAuthData :: T.Text -> DB.DB (Maybe BS.ByteString)
	180	userAuthData user =
	181	fmap DB.fromOnly <$>
	182	DB.queryMb "SELECT password FROM snap_auth_user WHERE login = ?"
	183	[DB.f user]

+44

-0

src/Inf/Log.hs less more

	1	module Inf.Log
	2	( debug
	3	, info
	4	, warn
	5	, error
	6	) where
	7
	8	import Control.Monad (when)
	9	import qualified Data.Time as Time
	10	import qualified System.IO.Unsafe as Unsafe
	11	import qualified System.Posix.IO as Unix
	12	import qualified System.Posix.Terminal as Unix
	13	import Prelude hiding (error)
	14
	15	isTTY :: Bool
	16	isTTY = Unsafe.unsafePerformIO (Unix.queryTerminal (Unix.stdOutput))
	17
	18	timeFmt :: String
	19	timeFmt = "[%Y-%m-%dT%H:%M:%S]"
	20
	21	timestamp :: IO String
	22	timestamp = do
	23	now <- Time.getCurrentTime
	24	pure (Time.formatTime Time.defaultTimeLocale timeFmt now)
	25
	26	logMsg :: String -> [String] -> IO ()
	27	logMsg color msg = do
	28	now <- timestamp
	29	when isTTY $ putStr color
	30	putStr (unwords (now:msg))
	31	when isTTY $ putStr "\x1b[39m"
	32	putStrLn ""
	33
	34	debug :: [String] -> IO ()
	35	debug = logMsg "\x1b[97m"
	36
	37	info :: [String] -> IO ()
	38	info = logMsg "\x1b[94m"
	39
	40	warn :: [String] -> IO ()
	41	warn = logMsg "\x1b[93m"
	42
	43	error :: [String] -> IO ()
	44	error = logMsg "\x1b[91m"

+79

-4

src/Inf/Templates.hs less more

4	4	( main
5	5	, page
6	6	, list
	7	, login
	8	, edit
	9	, post
	10	, delete
7	11
8	12	, dbException
9	13	, someException
10	14
11	15	, markdown
	16
	17	, InternalError(..)
12	18	) where
13	19
14	20	import qualified Control.Exception as Exn
15	21	import Control.Monad ((=<<))
16	22	import Data.Aeson ((.=))
17	23	import qualified Data.Aeson as Aeson
	24	import Data.Monoid ((<>))
18	25	import qualified Data.Text as TS
19	26	import qualified Data.Text.Lazy as T
20	27	import qualified Text.Mustache as Stache

26	33	import qualified Text.Pandoc.Writers.HTML as Pandoc
27	34
28	35	import Inf.Types
	36
	37	class InternalError t where
	38	renderedError :: t -> IO T.Text
	39	loggedError :: t -> String
	40
	41	instance InternalError DBException where
	42	renderedError = dbException
	43	loggedError = show
	44
	45	instance InternalError Exn.SomeException where
	46	renderedError = someException
	47	loggedError = show
	48
	49	instance InternalError Unimplemented where
	50	renderedError (Unimplemented _) =
	51	main Nothing "Unimplemented" =<<
	52	page "IMPLEMENT ME"
	53
	54	loggedError (Unimplemented msg) = "Unimplemented: " ++ msg
29	55
30	56	markdownOpts :: Pandoc.ReaderOptions
31	57	markdownOpts = Pandoc.def

42	68	pandoc <- Pandoc.readMarkdown markdownOpts raw
43	69	Pandoc.writeHtml5String htmlOpts pandoc
44	70
45		main :: T.Text -> T.Text -> IO T.Text
46		main title contents = do
	71	main :: Maybe TS.Text -> T.Text -> T.Text -> IO T.Text
	72	main user title contents = do
47	73	template <- Stache.compileMustacheFile "templates/main.mustache"
48	74	let vals = Aeson.object
49	75	[ "title" .= title
50	76	, "contents" .= contents
	77	, "user" .= case user of
	78	Nothing -> Aeson.toJSON ()
	79	Just u -> Aeson.object [ "name" .= u ]
51	80	]
52	81	pure (Stache.renderMustache template vals)
	82
	83	login :: IO T.Text
	84	login = do
	85	template <- Stache.compileMustacheFile "templates/login.mustache"
	86	pure (Stache.renderMustache template (Aeson.object []))
53	87
54	88	page :: TS.Text -> IO T.Text
55	89	page contents = do

57	91	mk <- markdown contents
58	92	let vals = Aeson.object
59	93	[ "contents" .= mk ]
	94	pure (Stache.renderMustache template vals)
	95
	96	nullable :: Maybe a -> (a -> [(TS.Text, Aeson.Value)]) -> Aeson.Value
	97	nullable Nothing _ = Aeson.toJSON ()
	98	nullable (Just x) k = Aeson.object (k x)
	99
	100	post :: Maybe TS.Text -> Post -> IO T.Text
	101	post user ps = do
	102	template <- Stache.compileMustacheFile "templates/post.mustache"
	103	mk <- markdown (postContents ps)
	104	let vals = Aeson.object
	105	[ "contents" .= mk
	106	, "user" .= nullable user (\_ ->
	107	[ "editurl" .= (postURL ps <> "/edit")
	108	, "delurl" .= (postURL ps <> "/delete")
	109	])
	110	, "next" .= nullable (postNext ps) (\nxt ->
	111	[ "link" .= postRefURL nxt ])
	112	, "prev" .= nullable (postPrev ps) (\nxt ->
	113	[ "link" .= postRefURL nxt ])
	114	]
	115	pure (Stache.renderMustache template vals)
	116
	117	edit :: TS.Text -> RawPost -> IO T.Text
	118	edit url ps = do
	119	template <- Stache.compileMustacheFile "templates/edit.mustache"
	120	let vals = Aeson.object
	121	[ "id" .= maybe "" (show . fromPostId) (rpId ps)
	122	, "title" .= rpTitle ps
	123	, "author" .= userName (rpAuthor ps)
	124	, "contents" .= rpContents ps
	125	, "url" .= url
	126	]
	127	pure (Stache.renderMustache template vals)
	128
	129	delete :: Post -> IO T.Text
	130	delete ps = do
	131	template <- Stache.compileMustacheFile "templates/delete.mustache"
	132	let vals = Aeson.object
	133	[ "post_url" .= postURL ps
	134	]
60	135	pure (Stache.renderMustache template vals)
61	136
62	137	list :: [PostRef] -> IO T.Text

75	150
76	151
77	152	dbException :: DBException -> IO T.Text
78		dbException exn = main "Error" =<< page (TS.unlines
	153	dbException exn = main Nothing "Error" =<< page (TS.unlines
79	154	( "## Internal server error"
80	155	: case exn of
81	156	NoSuchPost -> [ "database misconfiguration" ]

88	163	))
89	164
90	165	someException :: Exn.SomeException -> IO T.Text
91		someException exn = main "Internal Sever Error" =<< page (TS.unlines
	166	someException exn = main Nothing "Internal Sever Error" =<< page (TS.unlines
92	167	[ "The following unexpected error occurred:"
93	168	, "```"
94	169	, TS.pack (show exn)

+8

-4

src/Inf/Types.hs less more

43	43	{ postId :: PostId
44	44	, postDate :: Time.UTCTime
45	45	, postTitle :: T.Text
	46	, postSlug :: T.Text
46	47	, postContents :: T.Text
47	48	, postAuthor :: User
48	49	, postNext :: Maybe PostRef

100	101
101	102
102	103	postURL :: Post -> T.Text
103		postURL Post { postDate = date, post~~Title = title~~ } = do
	104	postURL Post { postDate = date, postSlug = slug } = do
104	105	let (year, month, _) = Time.toGregorian (Time.utctDay date) in
105	106	T.concat [ "/", T.pack (show year)
106	107	, "/", T.pack (show month)
107		, "/", slug~~ify title~~
	108	, "/", slug
108	109	]
109	110
110	111

112	113	postRefDateT PostRef { prDate = date } =
113	114	T.pack (Time.formatTime
114	115	Time.defaultTimeLocale
115		~~Time.rfc822DateFormat~~
	116	"%Y-%m-%d"
116	117	date)
	118
117	119
118	120	postRefURL :: PostRef -> T.Text
119	121	postRefURL PostRef { prYear = year, prMonth = month, prSlug = slug } =

140	142	}
141	143
142	144
143
144	145	data DBException
145	146	= MissingPost PostId
146	147	\| MissingPage T.Text

151	152	deriving (Eq, Show)
152	153
153	154	instance Exn.Exception DBException where
	155
	156	data Unimplemented = Unimplemented String
	157	deriving (Eq, Show)

+73

-0

src/Inf/Web/Cookies.hs less more

	1	{-# LANGUAGE OverloadedStrings #-}
	2
	3	module Inf.Web.Cookies
	4	( Cookies
	5	, getUser
	6	, verifyUser
	7	, authCookie
	8	, dumpCookies
	9	, parseCookies
	10	) where
	11
	12	import qualified Crypto.PasswordStore as Password
	13	import qualified Data.ByteString as BS
	14	import qualified Data.Text as TS
	15	import qualified Data.Text.Encoding as EncodingS
	16
	17	import qualified Inf.DB as DB
	18	import qualified Inf.DB.Monad as DB
	19	import qualified Inf.Log as Log
	20
	21	type Cookies = [(BS.ByteString, BS.ByteString)]
	22
	23	dumpCookies :: Cookies -> BS.ByteString
	24	dumpCookies cks = do
	25	BS.intercalate "; " [ BS.concat [k, "=", v]
	26	\| (k, v) <- cks
	27	]
	28
	29	-- \| Split a cookie string represented in the usual way into a list of
	30	-- key/value pairs
	31	parseCookies :: BS.ByteString -> Maybe Cookies
	32	parseCookies inp = do
	33	let (chunk, rest) = BS.breakSubstring "; " inp
	34	x <- case BS.breakSubstring "=" chunk of
	35	(_, "") -> Nothing
	36	(k, v) -> pure (k, BS.tail v)
	37	xs <- case rest of
	38	"" -> pure []
	39	rs -> parseCookies (BS.drop 2 rs)
	40	pure (x:xs)
	41
	42	authCookie :: BS.ByteString -> BS.ByteString -> Cookies
	43	authCookie user pass =
	44	[("USERDATA", BS.concat [user, ":", pass])]
	45
	46	verifyUser
	47	:: DB.Connection
	48	-> BS.ByteString
	49	-> BS.ByteString
	50	-> IO (Maybe TS.Text)
	51	verifyUser conn user passwd = do
	52	let userTxt = EncodingS.decodeUtf8 user
	53	authMb <- DB.runDB (DB.userAuthData userTxt) conn
	54	case authMb of
	55	Nothing -> do
	56	Log.warn [ "unable to find login data for", TS.unpack userTxt ]
	57	pure Nothing
	58	Just auth
	59	\| Password.verifyPassword passwd auth ->
	60	pure (Just userTxt)
	61	\| otherwise -> do
	62	Log.error [ "bad password for", TS.unpack userTxt ]
	63	pure Nothing
	64
	65	-- \| Find and verify a USERDATA cookie
	66	getUser :: DB.Connection -> Maybe BS.ByteString -> IO (Maybe TS.Text)
	67	getUser conn c = do
	68	let userDataMb = c >>= parseCookies >>= lookup "USERDATA"
	69	case userDataMb of
	70	Nothing -> pure Nothing
	71	Just userData -> do
	72	let (name, pass) = BS.breakSubstring ":" userData
	73	verifyUser conn name (BS.tail pass)

+54

-26

src/Inf/Web.hs less more

8	8	, raise404
9	9	, raise500
10	10	, redirect
	11	, redirectWithCookies
11	12	, atomFeed
	13
	14	, formData
	15	, module Web
12	16	) where
13	17
14		import Control.Monad ((>=>))
15	18	import qualified Control.Exception as Exn
	19	import qualified Data.ByteString.Char8 as BS8
16	20	import qualified Data.ByteString.Lazy as LBS
17	21	import qualified Data.Text as TS
18	22	import qualified Data.Text.Encoding as EncodingS
19	23	import qualified Data.Text.Lazy as T
20	24	import qualified Data.Text.Lazy.Encoding as Encoding
21	25	import qualified Network.HTTP.Types as HTTP
	26	import qualified Network.HTTP.Types.Header as HTTP
22	27	import qualified Network.Wai as W
23	28	import qualified Network.Wai.Handler.Warp as W
24	29	import qualified System.Environment as Env
25	30	import qualified Text.Read as Read
26	31
27	32	import qualified Inf.DB.Monad as DB
	33	import qualified Inf.Log as Log
28	34	import qualified Inf.Templates as Template
29		import Inf.~~Types~~
	35	import Inf.Web.Cookies as Web
30	36
31	37	type Routes = DB.Connection -> W.Request -> IO W.Response
32	38
	39	formData :: W.Request -> IO HTTP.Query
	40	formData =
	41	fmap (HTTP.parseQuery . LBS.toStrict) . W.lazyRequestBody
	42
33	43	run :: Routes -> IO ()
34	44	run routes = do
35		portVar <- Env.lookupEnv "~~port~~"
	45	portVar <- Env.lookupEnv "PORT"
36	46	let port = case portVar of
37	47	Just x
38	48	\| Just p <- Read.readMaybe x -> p
39	49	_ -> 8080
40		~~conn <- DB.open "test.db~~"
	50	dbVar <- Env.lookupEnv "DB"
	51	let dbLocation = case dbVar of
	52	Nothing -> "test.db"
	53	Just loc -> loc
	54	Log.info [ "opening database", show dbLocation ]
	55	conn <- DB.open dbLocation
	56	Log.info [ "running on port", show port ]
41	57	W.run port $ \ r k -> do
	58	Log.debug [ show (W.remoteHost r)
	59	, ":"
	60	, BS8.unpack (W.requestMethod r)
	61	, BS8.unpack (W.rawPathInfo r)
	62	]
42	63	resp <- routes conn r
43		`Exn.catch` (Template.dbException >=> raise500)
44		`Exn.catch` (Template.someException >=> raise500)
	64	`Exn.catch` (\ (e :: DB.DBException) -> raise500 r e)
	65	`Exn.catch` (\ (e :: Exn.SomeException) -> raise500 r e)
45	66	k resp
46	67
47		ok :: T.Text -> T.Text -> IO W.Response
48		ok title stuff = do
49		pg <- Template.main title stuff
	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
50	71	let headers = [(HTTP.hContentType, "text/html")]
51		pure (W.responseLBS HTTP.status200 [] (Encoding.encodeUtf8 pg))
	72	pure (W.responseLBS HTTP.status200 headers (Encoding.encodeUtf8 pg))
52	73
53		raise404 :: [TS.Text] -> IO W.Response
54		raise404 msgs = do
	74	raise404 :: W.Request -> [TS.Text] -> IO W.Response
	75	raise404 req msgs = do
	76	Log.warn [ " raised 404 for URL"
	77	, BS8.unpack (W.rawPathInfo req)
	78	]
55	79	contents <- Template.page $ TS.unwords
56	80	[ "No handler found for page "
57	81	, "`/" <> TS.intercalate "/" msgs <> "`"
58	82	]
59		pg <- Template.main "404" contents
	83	pg <- Template.main Nothing "404" contents
60	84	pure (W.responseLBS HTTP.status404 [] (Encoding.encodeUtf8 pg))
61	85
62		raise500 :: T.Text -> IO W.Response
63		raise500 msgs =
64		let body = Encoding.encodeUtf8 msgs
65		in pure (W.responseLBS HTTP.status500 [] body)
	86	raise500 :: Template.InternalError e => W.Request -> e -> IO W.Response
	87	raise500 req err = do
	88	Log.error [ " raised 500 for URL"
	89	, BS8.unpack (W.rawPathInfo req)
	90	, ":"
	91	, Template.loggedError err
	92	]
	93	body <- Encoding.encodeUtf8 `fmap` Template.renderedError err
	94	pure (W.responseLBS HTTP.status500 [] body)
66	95
67	96	redirect :: TS.Text -> IO W.Response
68	97	redirect url =
69	98	let headers = [(HTTP.hLocation, EncodingS.encodeUtf8 url)]
70		in pure (W.responseLBS HTTP.status307 headers "redirecting...")
	99	in pure (W.responseLBS HTTP.status303 headers "redirecting...")
	100
	101	redirectWithCookies :: TS.Text -> Web.Cookies -> IO W.Response
	102	redirectWithCookies url cookies =
	103	let headers = [ (HTTP.hLocation, EncodingS.encodeUtf8 url)
	104	, (HTTP.hSetCookie, Web.dumpCookies cookies)
	105	]
	106	in pure (W.responseLBS HTTP.status303 headers "redirecting...")
71	107
72	108	atomFeed :: LBS.ByteString -> IO W.Response
73	109	atomFeed feed =
74	110	let headers = [(HTTP.hContentType, "application/atom+xml")]
75	111	in pure (W.responseLBS HTTP.status200 headers feed)
76
77
78		getUser :: DB.Connection -> Maybe BS.ByteString -> IO (Maybe TS.Text)
79		getUser _ Nothing = pure Nothing
80		getUser _ (Just c) = maybe (pure Nothing) validateUser authCookie
81		where
82		cookies = TS.splitOn "; " (EncodingS.decodeUtf8 c)
83		authCookie = lookup "user" cookies

+114

-22

src/Main.hs less more

2	2
3	3	module Main where
4	4
5		import ~~qualified Data.ByteString as BS~~
	5	import Control.Monad (join)
6	6	import qualified Data.Text as TS
7	7	import qualified Data.Text.Encoding as EncodingS
8	8	import qualified Data.Text.Lazy as T

14	14	import qualified Inf.DB as DB
15	15	import qualified Inf.Feed as Feed
16	16	import qualified Inf.Templates as Template
	17	import qualified Inf.Log as Log
17	18	import Inf.Types
18	19	import qualified Inf.Web as Web
19	20
20	21	main :: IO ()
21	22	main = Web.run route
22	23
23		getUser :: DB.Connection -> Maybe BS.ByteString -> IO (Maybe TS.Text)
24		getUser _ Nothing = pure Nothing
25		getUser _ (Just c) =
26		let _cookies = TS.splitOn "; " (EncodingS.decodeUtf8 c)
27		in pure Nothing
28
29	24	route :: Web.Routes
30	25	route c req = do
31		~~_user <-~~ getUser c (lookup HTTP.hCookie (W.requestHeaders req))
	26	user <- Web.getUser c (lookup HTTP.hCookie (W.requestHeaders req))
32	27	case (W.requestMethod req, W.pathInfo req) of
33	28	("GET", []) -> do
34	29	post <- DB.runDB DB.newestPostRef c
35	30	Web.redirect (postRefURL post)
36	31
37		("POST", []) -> ~~undefined~~
	32	("POST", []) ->
	33	case user of
	34	Nothing -> do
	35	Log.error [ "non-logged-in user attempted to post something" ]
	36	Web.redirect "/"
	37	Just u -> do
	38	formData <- Web.formData req
	39	let rpMb = do
	40	title <- join (lookup "title" formData)
	41	contents <- join (lookup "contents" formData)
	42	pure RawPost
	43	{ rpId = Nothing
	44	, rpTitle = EncodingS.decodeUtf8 title
	45	, rpAuthor = User u
	46	, rpContents = EncodingS.decodeUtf8 contents
	47	}
	48	case rpMb of
	49	Nothing -> do
	50	Log.error [ "bad input data somehow" ]
	51	Web.redirect "/"
	52	Just rp -> do
	53	DB.runDB (DB.submitPost (User u) rp) c
	54	Web.redirect "/newest"
38	55
39		("GET", ["auth"]) -> ~~undefined~~
	56	("GET", ["auth"]) -> do
	57	password <- Template.login
	58	Web.ok user "login" password
40	59
41	60	("GET", ["archive"]) -> do
42	61	posts <- DB.runDB DB.allPostRefs c
43	62	contents <- Template.list posts
44		Web.ok "Past Entries" contents
	63	Web.ok user "Past Entries" contents
45	64
46		("GET", ["create"]) -> ~~undefined~~
	65	("GET", ["create"]) ->
	66	case user of
	67	Nothing -> Web.redirect "/"
	68	Just _ -> do
	69	contents <- Template.edit "/" emptyRawPost
	70	Web.ok user "New Post" contents
47	71
48	72	("GET", [y, m, s]) -> do
49	73	post <- DB.runDB (DB.postByDateAndSlug y m s) c
50		contents <- Template.page (postContents post)
51		Web.ok (T.fromStrict (postTitle post)) contents
	74	contents <- Template.post user post
	75	Web.ok user (T.fromStrict (postTitle post)) contents
52	76
53		("POST", [~~_y, _m, _s]) -> undefined~~
	77	("POST", [y, m, s]) ->
	78	case user of
	79	Nothing -> do
	80	Log.error [ "non-logged-in user attempted to edit post" ]
	81	Web.redirect "/"
	82	Just u -> do
	83	formData <- Web.formData req
	84	oldPost <- DB.runDB (DB.postByDateAndSlug y m s) c
	85	let rpMb = do
	86	title <- join (lookup "title" formData)
	87	contents <- join (lookup "contents" formData)
	88	pure RawPost
	89	{ rpId = Just (postId oldPost)
	90	, rpTitle = EncodingS.decodeUtf8 title
	91	, rpAuthor = User u
	92	, rpContents = EncodingS.decodeUtf8 contents
	93	}
	94	case rpMb of
	95	Nothing -> do
	96	Log.error [ "bad input data somehow" ]
	97	Web.redirect "/"
	98	Just rp -> do
	99	DB.runDB (DB.submitPost (User u) rp) c
	100	Web.redirect (postURL oldPost)
54	101
55		("~~GET", [_y, _m, _s, "edit"]) -> undefined~~
	102	("DELETE", [y, m, s]) ->
	103	case user of
	104	Nothing -> Web.redirect "/"
	105	Just _ -> do
	106	Log.warn [ "deleting post!" ]
	107	flip DB.runDB c $ do
	108	post <- DB.postByDateAndSlug y m s
	109	DB.deletePost (postToRawPost post)
	110	Web.redirect "/"
56	111
57		("GET", [~~_y, _m, _s, "delete"]) -> undefined~~
	112	("GET", [y, m, s, "edit"]) ->
	113	case user of
	114	Nothing -> do
	115	Log.error [ "non-logged-in user attempted to edit post" ]
	116	Web.redirect "/"
	117	Just {} -> do
	118	oldPost <- DB.runDB (DB.postByDateAndSlug y m s) c
	119	contents <- Template.edit (postURL oldPost) (postToRawPost oldPost)
	120	Web.ok user (T.fromStrict (postTitle oldPost)) contents
58	121
59		("GET", [~~"login"]) -> undefined~~
	122	("GET", [y, m, s, "delete"]) ->
	123	case user of
	124	Nothing -> Web.redirect "/"
	125	Just _ -> do
	126	post <- DB.runDB (DB.postByDateAndSlug y m s) c
	127	contents <- Template.delete post
	128	Web.ok user "Delete Post?" contents
60	129
61		("~~GET", ["logout"]) -> undefined~~
	130	("POST", ["login"]) -> do
	131	formData <- Web.formData req
	132	Log.warn [ "attempting login"
	133	, case lookup "user" formData of
	134	Just (Just u) -> "of user " ++ show u
	135	_ -> "without a specified user"
	136	]
	137	case (lookup "user" formData, lookup "passwd" formData) of
	138	(Just (Just u), Just (Just p)) -> do
	139	userMb <- Web.verifyUser c u p
	140	case userMb of
	141	Just _ ->
	142	let cookies = Web.authCookie u p
	143	in Web.redirectWithCookies "/" cookies
	144	Nothing -> Web.raise500 req (Unimplemented "Bad Password")
	145	_ -> Web.raise500 req (Unimplemented "Bad Login")
	146
	147	("GET", ["logout"]) ->
	148	Web.redirectWithCookies "/" [("USERDATA", "")]
62	149
63	150	("GET", ["newest"]) -> do
64	151	post <- DB.runDB DB.newestPostRef c

80	167	("GET", [pagename]) -> do
81	168	pg <- DB.runDB (DB.staticPage pagename) c
82	169	contents <- Template.page (pageText pg)
83		Web.ok (T.fromStrict pagename) contents
	170	Web.ok user (T.fromStrict pagename) contents
84	171
85		("GET", [_page, "edit"]) -> ~~undefined~~
	172	("GET", [_page, "edit"]) ->
	173	case user of
	174	Nothing -> Web.redirect "/"
	175	Just _ -> do
	176	contents <- Template.edit "/" emptyRawPost
	177	Web.ok user "New Post" contents
86	178
87		(_, path) -> Web.raise404 path
	179	(_, path) -> Web.raise404 req path

+31

-8

static/main.css less more

4	4	margin-right: 0px;
5	5	background-color: #FFFFFF;
6	6	color: #222222;
7		font-size: ~~large~~;
	7	font-size: 18pt;
	8	line-height: 1.5;
8	9	}
9	10
10	11	a:link { color: #bbbbbb; }
11	12	a:hover { color: #bbbbbb; }
12	13	a:active { color: #999999; }
13	14	a:visited { color: #999999; }
	15
	16	.postnav {
	17	width: 50%;
	18	margin-left: auto;
	19	margin-right: auto;
	20	padding: 20px;
	21	overflow: auto;
	22	}
14	23
15	24	.username {
16	25	width: 100%;

125	134	}
126	135
127	136	.new {
128		display: inline-block;
129		width: 50%;
130		~~text-align~~: left;
	137	float: left;
	138	background-color: #444;
	139	color: #fff;
	140	padding: 12px;
	141	height: 100%;
131	142	}
132	143
	144	.new a { #fff; }
	145	.new a visited { #fff; }
	146
133	147	.old {
134		display: inline-block;
135		width: 50%;
136		~~text-align~~: right;
	148	float: right;
	149	background-color: #444;
	150	color: #fff;
	151	padding: 12px;
	152	height: 100%;
	153	}
	154
	155	.old a { #fff; }
	156	.old a visited { #fff; }
	157
	158	.inactive {
	159	color: #ddd;
137	160	}
138	161
139	162	pre {

146	169
147	170	code {
148	171	padding: 2px;
149		}⏎
	172	}

+1

-1

templates/edit.mustache less more

1	1	<div class="edit">
2		<form name="newpost" action="/" method="POST"
	2	<form name="newpost" action="{{url}}" method="POST"
3	3	enctype="application/x-www-form-urlencoded;charset=UTF-8">
4	4	<input type="hidden" name="id" value="{{id}}"/>
5	5	<input type="text" name="title" value="{{title}}"/>

+1

-1

templates/list.mustache less more

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

+30

-9

templates/post.mustache less more

1		<div class="postbody">
2
	1	<div class="post">
	2	<div class="postbody">
	3	{{{contents}}}
	4	</div>
	5	{{#user}}
	6	<div class="editlink">
	7	<a href="{{editurl}}">Edit this post</a>
	8	</div>
	9	<div class="editlink">
	10	<a href="{{delurl}}">Delete this post</a>
	11	</div>
	12	{{/user}}
3	13	</div>
4		<div class="new">
5		{{#next}}
6		{{/next}}
	14
	15	<div class="postnav">
	16	<span class="new">
	17	{{#next}}
	18	<a href="{{link}}">Newer</a>
	19	{{/next}}
	20	{{^next}}
	21	<span class="inactive">Newer</span>
	22	{{/next}}
	23	</span>
	24	<span class="old">
	25	{{#prev}}
	26	<a href="{{link}}">Older</a>
	27	{{/prev}}
	28	{{^prev}}
	29	<span class="inactive">Older</span>
	30	{{/prev}}
	31	</span>
7	32	</div>
8		<div class="old">
9		{{#prev}}
10		{{/prev}}
11		</div>