Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

Add a simple project template that demonstrates basic usage of the auth snaplet #33

Closed
wants to merge 1 commit into from

2 participants

Janne Hellsten Doug Beardsley
Janne Hellsten

As discussed on #snapframework - ported code to run on snap 0.9 branch + made better use of handler helpers and splices.

Janne Hellsten nurpax Add auth snaplet project template
Add a simple project template that demonstrates basic usage of the auth snaplet.
d8d1181
Doug Beardsley
Owner

I merged it in. There were still a few rough edges and it wasn't quite working with 0.9. But thank you very much. This is a great contribution.

Doug Beardsley mightybyte closed this
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Jun 3, 2012
  1. Janne Hellsten

    Add auth snaplet project template

    nurpax authored
    Add a simple project template that demonstrates basic usage of the auth snaplet.
This page is out of date. Refresh to see the latest.
4 project_template/auth/.ghci
View
@@ -0,0 +1,4 @@
+:set -isrc
+:set -hide-package MonadCatchIO-mtl
+:set -hide-package monads-fd
+:set -XOverloadedStrings
50 project_template/auth/foo.cabal
View
@@ -0,0 +1,50 @@
+Name: projname
+Version: 0.1
+Synopsis: Project Synopsis Here
+Description: Project Description Here
+License: AllRightsReserved
+Author: Author
+Maintainer: maintainer@example.com
+Stability: Experimental
+Category: Web
+Build-type: Simple
+Cabal-version: >=1.2
+
+Flag development
+ Description: Whether to build the server in development (interpreted) mode
+ Default: False
+
+Executable projname
+ hs-source-dirs: src
+ main-is: Main.hs
+
+ Build-depends:
+ base >= 4 && < 5,
+ bytestring >= 0.9.1 && < 0.10,
+ data-lens >= 2.0.1 && < 2.11,
+ data-lens-template >= 2.1 && < 2.2,
+ heist >= 0.8 && < 0.9,
+ MonadCatchIO-transformers >= 0.2.1 && < 0.4,
+ mtl >= 2 && < 3,
+ snap >= 0.9 && < 0.10,
+ snap-core >= 0.9 && < 0.10,
+ snap-server >= 0.9 && < 0.10,
+ text >= 0.11 && < 0.12,
+ time >= 1.1 && < 1.5,
+ xmlhtml >= 0.1 && < 0.2
+
+ if flag(development)
+ cpp-options: -DDEVELOPMENT
+ -- In development mode, speed is already going to suffer, so skip
+ -- the fancy optimization flags. Additionally, disable all
+ -- warnings. The hint library doesn't give an option to execute
+ -- compiled code when there were also warnings, so disabling
+ -- warnings allows quicker workflow.
+ ghc-options: -threaded -w
+ else
+ if impl(ghc >= 6.12.0)
+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-orphans -fno-warn-unused-do-bind
+ else
+ ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2
+ -fno-warn-orphans
0  project_template/auth/log/access.log
View
No changes.
0  project_template/auth/log/error.log
View
No changes.
13 project_template/auth/snaplets/heist/templates/base.tpl
View
@@ -0,0 +1,13 @@
+<html>
+ <head>
+ <title>Snap web server</title>
+ <link rel="stylesheet" type="text/css" href="/screen.css"/>
+ </head>
+ <body>
+ <div id="content">
+
+ <content/>
+
+ </div>
+ </body>
+</html>
13 project_template/auth/snaplets/heist/templates/index.tpl
View
@@ -0,0 +1,13 @@
+<apply template="base">
+
+ <p>
+ This is a simple demo page served using
+ <a href="http://snapframework.com/docs/tutorials/heist">Heist</a>
+ and the <a href="http://snapframework.com/">Snap</a> web framework.
+ </p>
+
+ <ifLoggedIn><p>Congrats! You're logged in as '<loggedInUser/>'</p></ifLoggedIn>
+
+ <p><a href="/logout">Logout</a></p>
+
+</apply>
11 project_template/auth/snaplets/heist/templates/login.tpl
View
@@ -0,0 +1,11 @@
+<apply template="base">
+ <h1>Login</h1>
+
+ <p><loginError/></p>
+
+ <bind tag="postAction">/login</bind>
+ <bind tag="submitText">Login</bind>
+ <apply template="userform"/>
+
+ <p>Don't have a login yet? <a href="/new_user">Create a new user</a></p>
+</apply>
9 project_template/auth/snaplets/heist/templates/new_user.tpl
View
@@ -0,0 +1,9 @@
+<apply template="base">
+
+ <h1>Register a new user</h1>
+
+ <bind tag="postAction">/new_user</bind>
+ <bind tag="submitText">Add User</bind>
+ <apply template="userform"/>
+
+</apply>
14 project_template/auth/snaplets/heist/templates/userform.tpl
View
@@ -0,0 +1,14 @@
+<form method="post" action="${postAction}">
+ <table id="info">
+ <tr>
+ <td>Login:</td><td><input type="text" name="login" size="20" /></td>
+ </tr>
+ <tr>
+ <td>Password:</td><td><input type="password" name="password" size="20" /></td>
+ </tr>
+ <tr>
+ <td></td>
+ <td><input type="submit" value="${submitText}" /></td>
+ </tr>
+ </table>
+</form>
32 project_template/auth/src/Application.hs
View
@@ -0,0 +1,32 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+------------------------------------------------------------------------------
+-- | This module defines our application's state type and an alias for its
+-- handler monad.
+--
+module Application where
+
+------------------------------------------------------------------------------
+import Data.Lens.Template
+import Snap.Snaplet
+import Snap.Snaplet.Heist
+import Snap.Snaplet.Auth
+import Snap.Snaplet.Session
+
+------------------------------------------------------------------------------
+data App = App
+ { _heist :: Snaplet (Heist App)
+ , _sess :: Snaplet SessionManager
+ , _auth :: Snaplet (AuthManager App)
+ }
+
+makeLens ''App
+
+instance HasHeist App where
+ heistLens = subSnaplet heist
+
+
+------------------------------------------------------------------------------
+type AppHandler = Handler App App
+
+
102 project_template/auth/src/Main.hs
View
@@ -0,0 +1,102 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+------------------------------------------------------------------------------
+import Control.Exception (SomeException, try)
+import qualified Data.Text as T
+import Snap.Http.Server
+import Snap.Snaplet
+import Snap.Snaplet.Config
+import Snap.Core
+import System.IO
+import Site
+
+#ifdef DEVELOPMENT
+import Snap.Loader.Devel
+#else
+import Snap.Loader.Prod
+#endif
+
+
+------------------------------------------------------------------------------
+-- | This is the entry point for this web server application. It supports
+-- easily switching between interpreting source and running statically compiled
+-- code.
+--
+-- In either mode, the generated program should be run from the root of the
+-- project tree. When it is run, it locates its templates, static content, and
+-- source files in development mode, relative to the current working directory.
+--
+-- When compiled with the development flag, only changes to the libraries, your
+-- cabal file, or this file should require a recompile to be picked up.
+-- Everything else is interpreted at runtime. There are a few consequences of
+-- this.
+--
+-- First, this is much slower. Running the interpreter takes a significant
+-- chunk of time (a couple tenths of a second on the author's machine, at this
+-- time), regardless of the simplicity of the loaded code. In order to
+-- recompile and re-load server state as infrequently as possible, the source
+-- directories are watched for updates, as are any extra directories specified
+-- below.
+--
+-- Second, the generated server binary is MUCH larger, since it links in the
+-- GHC API (via the hint library).
+--
+-- Third, and the reason you would ever want to actually compile with
+-- development mode, is that it enables a faster development cycle. You can
+-- simply edit a file, save your changes, and hit reload to see your changes
+-- reflected immediately.
+--
+-- When this is compiled without the development flag, all the actions are
+-- statically compiled in. This results in faster execution, a smaller binary
+-- size, and having to recompile the server for any code change.
+--
+main :: IO ()
+main = do
+ -- Depending on the version of loadSnapTH in scope, this either enables
+ -- dynamic reloading, or compiles it without. The last argument to
+ -- loadSnapTH is a list of additional directories to watch for changes to
+ -- trigger reloads in development mode. It doesn't need to include source
+ -- directories, those are picked up automatically by the splice.
+ (conf, site, cleanup) <- $(loadSnapTH [| getConf |]
+ 'getActions
+ ["snaplets/heist/templates"])
+
+ _ <- try $ httpServe conf $ site :: IO (Either SomeException ())
+ cleanup
+
+
+------------------------------------------------------------------------------
+-- | This action loads the config used by this application. The loaded config
+-- is returned as the first element of the tuple produced by the loadSnapTH
+-- Splice. The type is not solidly fixed, though it must be an IO action that
+-- produces the same type as 'getActions' takes. It also must be an instance of
+-- Typeable. If the type of this is changed, a full recompile will be needed to
+-- pick up the change, even in development mode.
+--
+-- This action is only run once, regardless of whether development or
+-- production mode is in use.
+getConf :: IO (Config Snap AppConfig)
+getConf = commandLineAppConfig defaultConfig
+
+
+------------------------------------------------------------------------------
+-- | This function generates the the site handler and cleanup action from the
+-- configuration. In production mode, this action is only run once. In
+-- development mode, this action is run whenever the application is reloaded.
+--
+-- Development mode also makes sure that the cleanup actions are run
+-- appropriately before shutdown. The cleanup action returned from loadSnapTH
+-- should still be used after the server has stopped handling requests, as the
+-- cleanup actions are only automatically run when a reload is triggered.
+--
+-- This sample doesn't actually use the config passed in, but more
+-- sophisticated code might.
+getActions :: Config Snap AppConfig -> IO (Snap (), IO ())
+getActions conf = do
+ (msgs, site, cleanup) <- runSnaplet
+ (appEnvironment =<< getOther conf) app
+ hPutStrLn stderr $ T.unpack msgs
+ return (site, cleanup)
90 project_template/auth/src/Site.hs
View
@@ -0,0 +1,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
26 project_template/auth/static/screen.css
View
@@ -0,0 +1,26 @@
+html {
+ padding: 0;
+ margin: 0;
+ background-color: #ffffff;
+ font-family: Verdana, Helvetica, sans-serif;
+}
+body {
+ padding: 0;
+ margin: 0;
+}
+a {
+ text-decoration: underline;
+}
+a :hover {
+ cursor: pointer;
+ text-decoration: underline;
+}
+img {
+ border: none;
+}
+#content {
+ padding-left: 1em;
+}
+#info {
+ font-size: 60%;
+}
Something went wrong with that request. Please try again.