Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Add auth snaplet project template

Add a simple project template that demonstrates basic usage of the auth snaplet.
  • Loading branch information...
commit d8d11811ce44f2b6ee8bce6922e322cc924e2d6d 1 parent b6a11d4
Janne Hellsten nurpax authored
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%;
+}
Please sign in to comment.
Something went wrong with that request. Please try again.