/
Site.hs
90 lines (79 loc) · 3.36 KB
/
Site.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
{-# LANGUAGE OverloadedStrings #-}
------------------------------------------------------------------------------
-- | This module is where all the routes and handlers are defined for your
-- site. The 'app' function is the initializer that combines everything
-- together and is exported by this module.
--
module Site
( app
) where
------------------------------------------------------------------------------
import Control.Applicative
import Data.ByteString (ByteString)
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.Auth
import Snap.Snaplet.Auth.Backends.JsonFile
import Snap.Snaplet.Heist
import Snap.Snaplet.Session.Backends.CookieSession
import Snap.Util.FileServe
import Text.Templating.Heist
------------------------------------------------------------------------------
import Application
------------------------------------------------------------------------------
-- | Renders the front page of the sample site.
--
-- The 'ifTop' is required to limit this to the top of a route.
-- Otherwise, the way the route table is currently set up, this action
-- would be given every request.
index :: Handler App (AuthManager App) ()
index =
ifTop $ requireUser auth (handleLogin Nothing) loggedIn where
loggedIn = do
acc <- fmap (maybe "" userLogin) currentUser
heistLocal (bindString "login" acc) $ render "index"
-- Render login form
handleLogin :: Maybe T.Text -> Handler App (AuthManager App) ()
handleLogin authError =
heistLocal (bindSplices errs) $ render "login" where
errs = [("loginError", textSplice c) | c <- maybeToList authError]
-- Handle login submit
handleLoginSubmit :: Handler App (AuthManager App) ()
handleLoginSubmit =
loginUser "login" "password" Nothing (\_ -> handleLogin err) (redirect "/") where
err = Just . T.pack $ "Unknown user or password"
handleLogout :: Handler App (AuthManager App) ()
handleLogout = do
logout
redirect "/"
-- Handle new user form submit
handleNewUser :: Handler App (AuthManager App) ()
handleNewUser = method GET handleForm <|> method POST handleFormSubmit where
handleForm =
heistLocal (bindSplices []) $ render "new_user"
handleFormSubmit = do
registerUser "login" "password"
redirect "/"
------------------------------------------------------------------------------
-- | The application's routes.
routes :: [(ByteString, Handler App App ())]
routes = [ ("/", with auth $ index)
, ("/login", with auth $ handleLoginSubmit)
, ("/logout", with auth $ handleLogout)
, ("/new_user", with auth $ handleNewUser)
, ("", with heist heistServe)
, ("", serveDirectory "static")
]
------------------------------------------------------------------------------
-- | The application initializer.
app :: SnapletInit App App
app = makeSnaplet "app" "An snaplet example application." Nothing $ do
h <- nestSnaplet "heist" heist $ heistInit "templates"
s <- nestSnaplet "sess" sess $ initCookieSessionManager "site_key.txt" "sess" (Just 3600)
a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings sess "users.json"
addRoutes routes
addAuthSplices auth
return $ App h s a