gdritter repos new-inf-blog / 3a0faa3
just scattered first efforts Getty Ritter 7 years ago
5 changed file(s) with 307 addition(s) and 0 deletion(s). Collapse all Expand all
+20
-0
.gitignore less more
1 dist
2 dist-*
3 *~
4 cabal-dev
5 *.o
6 *.hi
7 *.chi
8 *.chs.h
9 *.dyn_o
10 *.dyn_hi
11 .hpc
12 .hsenv
13 .cabal-sandbox/
14 cabal.sandbox.config
15 *.prof
16 *.aux
17 *.hp
18 *.eventlog
19 cabal.project.local
20 .ghc.environment.*
+27
-0
new-inf-blog.cabal less more
1 name: new-inf-blog
2 version: 0.1.0.0
3 -- synopsis:
4 -- description:
5 license: BSD3
6 author: Getty Ritter <gettylefou@gmail.com>
7 maintainer: Getty Ritter <gettylefou@gmail.com>
8 copyright: @2018 Getty Ritter
9 -- category:
10 build-type: Simple
11 cabal-version: >=1.14
12
13 executable new-inf-blog
14 hs-source-dirs: src
15 main-is: Main.hs
16 other-modules: Inf.Types
17 Inf.DB
18 default-language: Haskell2010
19 default-extensions: ScopedTypeVariables
20 ghc-options: -Wall
21 build-depends: base >=4.7 && <5
22 , wai
23 , warp
24 , stache
25 , text
26 , time
27 , sqlite-simple⏎
+91
-0
src/Inf/DB.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Inf.DB where
4
5 import qualified Control.Exception as Exn
6 import qualified Database.SQLite.Simple as SQL
7 import qualified Data.Text as T
8 import qualified Data.Time as Time
9 import Data.Typeable (Typeable)
10
11 import Inf.Types
12
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
30 Just (PostId n) | uname == rpAuthor rp -> do
31 pure ()
32 SQL.execute c
33 "UPDATE posts \
34 \ SET title = ?, author = ?, contents = ? \
35 \ WHERE id = ?"
36 (rpTitle rp, userName (rpAuthor rp), rpContents rp, n)
37 SQL.execute c
38 "UPDATE lookup SET slug = ? WHERE post_id = ?"
39 (slugify (rpTitle rp), n)
40 pure True
41
42 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
47 "INSERT INTO posts \
48 \ (title, contents, author, time, next, prev) \
49 \ VALUES (?, ?, ?, ?, ?, ?)"
50 (rpTitle rp, rpContents rp, rpAuthor rp, now, Nothing :: Maybe Int, prev :: Maybe Int)
51
52 new <- SQL.lastInsertRowId c
53 case prev of
54 Just p -> SQL.execute c
55 "UPDATE posts SET next = ? WHERE id = ?" (new, p)
56 Nothing -> pure ()
57
58 let (year, month, _) = Time.toGregorian (Time.utctDay now)
59 SQL.execute c
60 "INSERT INTO lookup (year, month, time, slug, post_id) \
61 \ VALUES (?, ?, ?, ?, ?)"
62 (year, month, now, slugify (rpTitle rp), new)
63 pure True
64
65 _ -> pure False
66
67 deletePost :: RawPost -> DB Bool
68 deletePost rp c
69 | Just post <- rpId rp = do
70 vals <- SQL.query c
71 "SELECT next, prev FROM posts WHERE id = ?"
72 (SQL.Only post)
73
74 (oldNext :: Maybe Int, oldPrev :: Maybe Int) <- case vals of
75 [] -> Exn.throwIO (MissingPost post)
76 (x, y):_ -> pure (x, y)
77
78 case oldPrev of
79 Just n -> SQL.execute c
80 "UPDATE posts SET next = ? WHERE id = ?" (oldNext, n)
81 Nothing -> pure ()
82
83 case oldNext of
84 Just n -> SQL.execute c
85 "UPDATE posts SET prev = ? WHERE id = ?" (oldPrev, n)
86 Nothing -> pure ()
87
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
+125
-0
src/Inf/Types.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Inf.Types where
4
5 import qualified Data.Char as Char
6 import qualified Data.Text as T
7 import qualified Data.Time as Time
8 import qualified Database.SQLite.Simple as SQL
9 import qualified Database.SQLite.Simple.FromField as SQL
10 import qualified Database.SQLite.Simple.ToField as SQL
11
12 newtype PostId = PostId { fromPostId :: Int } deriving (Eq, Show)
13
14 instance SQL.FromField PostId where
15 fromField f = PostId `fmap` SQL.fromField f
16
17 instance SQL.ToField PostId where
18 toField = SQL.toField . fromPostId
19
20 newtype User = User { userName :: T.Text } deriving (Eq, Show)
21
22 instance SQL.FromField User where
23 fromField f = User `fmap` SQL.fromField f
24
25 instance SQL.ToField User where
26 toField = SQL.toField . userName
27
28
29 -- | A 'PostRef' is just the information needed to identify a post
30 -- internally, including when it was posted and its title and slug
31 data PostRef = PostRef
32 { prYear :: Int
33 , prMonth :: Int
34 , prSlug :: T.Text
35 , prName :: T.Text
36 , prDate :: Time.UTCTime
37 } deriving Show
38
39 -- | A 'Post' is all the information needed to display a post in full,
40 -- including the raw Markdown of the post itself
41 data Post = Post
42 { postId :: PostId
43 , postDate :: Time.UTCTime
44 , postTitle :: T.Text
45 , postContents :: T.Text
46 , postAuthor :: User
47 , postNext :: Maybe PostRef
48 , postPrev :: Maybe PostRef
49 } deriving Show
50
51 -- | A 'RawPost' is the information needed to create a new post, and
52 -- thus may not have a post ID (as it might not have been submitted
53 -- yet!)
54 data RawPost = RawPost
55 { rpId :: Maybe PostId
56 , rpTitle :: T.Text
57 , rpAuthor :: User
58 , rpContents :: T.Text
59 } deriving Show
60
61 -- | A blank post for populating an editing field
62 emptyRawPost :: RawPost
63 emptyRawPost = RawPost
64 { rpId = Nothing
65 , rpTitle = ""
66 , rpAuthor = User { userName = "" }
67 , rpContents = ""
68 }
69
70
71 data URL = URL
72 { urlRelative :: T.Text
73 , urlAbsolute :: T.Text
74 } deriving Show
75
76
77 mkURL :: [T.Text] -> URL
78 mkURL path =
79 let pathJoined = T.intercalate "/" path
80 root = "https://blog.infinitenegativeutility.com"
81 in URL { urlRelative = T.cons '/' pathJoined
82 , urlAbsolute = root `T.append` T.cons '/' pathJoined
83 }
84
85
86 postDateT :: Post -> T.Text
87 postDateT Post { postDate = date } =
88 T.pack (Time.formatTime
89 Time.defaultTimeLocale
90 Time.rfc822DateFormat
91 date)
92
93
94 postURL :: Post -> T.Text
95 postURL Post { postDate = date, postTitle = title } = do
96 let (year, month, _) = Time.toGregorian (Time.utctDay date) in
97 T.concat [ "/", T.pack (show year)
98 , "/", T.pack (show month)
99 , "/", slugify title
100 ]
101
102
103 postRefURL :: PostRef -> T.Text
104 postRefURL PostRef { prYear = year, prMonth = month, prSlug = slug } =
105 T.concat [ "/", T.pack (show year)
106 , "/", T.pack (show month)
107 , "/", slug
108 ]
109
110
111 slugify :: T.Text -> T.Text
112 slugify = T.map conv
113 where
114 conv c
115 | Char.isAlphaNum c = Char.toLower c
116 | otherwise = '-'
117
118
119 postToRawPost :: Post -> RawPost
120 postToRawPost p = RawPost
121 { rpId = Just (postId p)
122 , rpTitle = postTitle p
123 , rpContents = postContents p
124 , rpAuthor = postAuthor p
125 }
+44
-0
src/Main.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Main where
4
5 import qualified Data.Text as T
6 import qualified Network.Wai as W
7 import qualified Network.Wai.Handler.Warp as W
8 import qualified System.Environment as Env
9 import qualified Text.Read as Read
10
11 main :: IO ()
12 main = do
13 portVar <- Env.lookupEnv "port"
14 let port = case portVar of
15 Just x
16 | Just p <- Read.readMaybe x -> p
17 _ -> 8080
18 W.run port (\ r k -> route r >>= k)
19
20
21 raise404 :: [T.Text] -> IO W.Response
22 raise404 = undefined
23
24
25 route :: W.Request -> IO W.Response
26 route req = case (W.requestMethod req, W.pathInfo req) of
27 ("GET", []) -> undefined
28 ("POST", []) -> undefined
29 ("GET", ["auth"]) -> undefined
30 ("GET", ["archive"]) -> undefined
31 ("GET", ["create"]) -> undefined
32 ("GET", [y, m, s]) -> undefined
33 ("POST", [y, m, s]) -> undefined
34 ("GET", [y, m, s, "edit"]) -> undefined
35 ("GET", [y, m, s, "delete"]) -> undefined
36 ("GET", ["login"]) -> undefined
37 ("GET", ["logout"]) -> undefined
38 ("GET", ["oldest"]) -> undefined
39 ("GET", ["static", fp]) -> undefined
40 ("GET", ["rss"]) -> undefined
41 ("GET", [page]) -> undefined
42 ("GET", [page, "edit"]) -> undefined
43 (_, path) -> raise404 path
44