gdritter repos new-inf-blog / 57dadc3
Refactor web utils into Web module Getty Ritter 6 years ago
3 changed file(s) with 136 addition(s) and 83 deletion(s). Collapse all Expand all
+3
-1
new-inf-blog.cabal less more
1818 Inf.DB
1919 Inf.DB.Monad
2020 Inf.Feed
21 Inf.Web
2122 default-language: Haskell2010
2223 default-extensions: ScopedTypeVariables
2324 ghc-options: -Wall
3536 , feed
3637 , xml-types
3738 , xml-conduit
38 , bytestring⏎
39 , bytestring
40 , pwstore-fast
+83
-0
src/Inf/Web.hs less more
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module Inf.Web
4 ( run
5 , Routes
6
7 , ok
8 , raise404
9 , raise500
10 , redirect
11 , atomFeed
12 ) where
13
14 import Control.Monad ((>=>))
15 import qualified Control.Exception as Exn
16 import qualified Data.ByteString.Lazy as LBS
17 import qualified Data.Text as TS
18 import qualified Data.Text.Encoding as EncodingS
19 import qualified Data.Text.Lazy as T
20 import qualified Data.Text.Lazy.Encoding as Encoding
21 import qualified Network.HTTP.Types as HTTP
22 import qualified Network.Wai as W
23 import qualified Network.Wai.Handler.Warp as W
24 import qualified System.Environment as Env
25 import qualified Text.Read as Read
26
27 import qualified Inf.DB.Monad as DB
28 import qualified Inf.Templates as Template
29 import Inf.Types
30
31 type Routes = DB.Connection -> W.Request -> IO W.Response
32
33 run :: Routes -> IO ()
34 run routes = do
35 portVar <- Env.lookupEnv "port"
36 let port = case portVar of
37 Just x
38 | Just p <- Read.readMaybe x -> p
39 _ -> 8080
40 conn <- DB.open "test.db"
41 W.run port $ \ r k -> do
42 resp <- routes conn r
43 `Exn.catch` (Template.dbException >=> raise500)
44 `Exn.catch` (Template.someException >=> raise500)
45 k resp
46
47 ok :: T.Text -> T.Text -> IO W.Response
48 ok title stuff = do
49 pg <- Template.main title stuff
50 let headers = [(HTTP.hContentType, "text/html")]
51 pure (W.responseLBS HTTP.status200 [] (Encoding.encodeUtf8 pg))
52
53 raise404 :: [TS.Text] -> IO W.Response
54 raise404 msgs = do
55 contents <- Template.page $ TS.unwords
56 [ "No handler found for page "
57 , "`/" <> TS.intercalate "/" msgs <> "`"
58 ]
59 pg <- Template.main "404" contents
60 pure (W.responseLBS HTTP.status404 [] (Encoding.encodeUtf8 pg))
61
62 raise500 :: T.Text -> IO W.Response
63 raise500 msgs =
64 let body = Encoding.encodeUtf8 msgs
65 in pure (W.responseLBS HTTP.status500 [] body)
66
67 redirect :: TS.Text -> IO W.Response
68 redirect url =
69 let headers = [(HTTP.hLocation, EncodingS.encodeUtf8 url)]
70 in pure (W.responseLBS HTTP.status307 headers "redirecting...")
71
72 atomFeed :: LBS.ByteString -> IO W.Response
73 atomFeed feed =
74 let headers = [(HTTP.hContentType, "application/atom+xml")]
75 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
+50
-82
src/Main.hs less more
22
33 module Main where
44
5 import qualified Control.Exception as Exn
6 import Control.Monad ((>=>))
5 import qualified Data.ByteString as BS
76 import qualified Data.Text as TS
87 import qualified Data.Text.Encoding as EncodingS
98 import qualified Data.Text.Lazy as T
10 import qualified Data.Text.Lazy.Encoding as Encoding
119 import qualified Network.HTTP.Types as HTTP
1210 import qualified Network.Wai as W
13 import qualified Network.Wai.Handler.Warp as W
1411 import System.FilePath ((</>))
15 import qualified System.Environment as Env
16 import qualified Text.Read as Read
1712
1813 import qualified Inf.DB.Monad as DB
1914 import qualified Inf.DB as DB
2015 import qualified Inf.Feed as Feed
2116 import qualified Inf.Templates as Template
2217 import Inf.Types
18 import qualified Inf.Web as Web
2319
2420 main :: IO ()
25 main = do
26 portVar <- Env.lookupEnv "port"
27 let port = case portVar of
28 Just x
29 | Just p <- Read.readMaybe x -> p
30 _ -> 8080
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
21 main = Web.run route
3722
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))
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
4328
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))
29 route :: Web.Routes
30 route c req = do
31 _user <- getUser c (lookup HTTP.hCookie (W.requestHeaders req))
32 case (W.requestMethod req, W.pathInfo req) of
33 ("GET", []) -> do
34 post <- DB.runDB DB.newestPostRef c
35 Web.redirect (postRefURL post)
5236
53 raise500 :: T.Text -> IO W.Response
54 raise500 msgs =
55 let body = Encoding.encodeUtf8 msgs
56 in pure (W.responseLBS HTTP.status500 [] body)
37 ("POST", []) -> undefined
5738
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...")
39 ("GET", ["auth"]) -> undefined
6440
65 ("POST", []) -> undefined
41 ("GET", ["archive"]) -> do
42 posts <- DB.runDB DB.allPostRefs c
43 contents <- Template.list posts
44 Web.ok "Past Entries" contents
6645
67 ("GET", ["auth"]) -> undefined
46 ("GET", ["create"]) -> undefined
6847
69 ("GET", ["archive"]) -> do
70 posts <- DB.runDB DB.allPostRefs c
71 contents <- Template.list posts
72 page "Past Entries" contents
48 ("GET", [y, m, s]) -> do
49 post <- DB.runDB (DB.postByDateAndSlug y m s) c
50 contents <- Template.page (postContents post)
51 Web.ok (T.fromStrict (postTitle post)) contents
7352
74 ("GET", ["create"]) -> undefined
53 ("POST", [_y, _m, _s]) -> undefined
7554
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
55 ("GET", [_y, _m, _s, "edit"]) -> undefined
8056
81 ("POST", [y, m, s]) -> undefined
57 ("GET", [_y, _m, _s, "delete"]) -> undefined
8258
83 ("GET", [y, m, s, "edit"]) -> undefined
59 ("GET", ["login"]) -> undefined
8460
85 ("GET", [y, m, s, "delete"]) -> undefined
61 ("GET", ["logout"]) -> undefined
8662
87 ("GET", ["login"]) -> undefined
63 ("GET", ["newest"]) -> do
64 post <- DB.runDB DB.newestPostRef c
65 Web.redirect (postRefURL post)
8866
89 ("GET", ["logout"]) -> undefined
67 ("GET", ["oldest"]) -> do
68 post <- DB.runDB DB.oldestPostRef c
69 Web.redirect (postRefURL post)
9070
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...")
71 ("GET", ["static", fp]) ->
72 let path = "static" </> TS.unpack fp
73 in pure (W.responseFile HTTP.status200 [] path Nothing)
9574
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...")
75 ("GET", ["rss"]) -> do
76 posts <- DB.runDB DB.allPosts c
77 feed <- Feed.renderFeed posts
78 Web.atomFeed feed
10079
101 ("GET", ["static", fp]) ->
102 let path = "static" </> TS.unpack fp
103 in pure (W.responseFile HTTP.status200 [] path Nothing)
80 ("GET", [pagename]) -> do
81 pg <- DB.runDB (DB.staticPage pagename) c
82 contents <- Template.page (pageText pg)
83 Web.ok (T.fromStrict pagename) contents
10484
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)
85 ("GET", [_page, "edit"]) -> undefined
11186
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
117 ("GET", [page, "edit"]) -> undefined
118
119 (_, path) -> raise404 path
87 (_, path) -> Web.raise404 path