Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: lulf/wishsys
base: 12e0d0bc87
...
head fork: lulf/wishsys
compare: 082b433559
Checking mergeability… Don't worry, you can still create the pull request.
  • 8 commits
  • 1 file changed
  • 0 commit comments
  • 1 contributor
Showing with 141 additions and 80 deletions.
  1. +141 −80 src/Main.hs
View
221 src/Main.hs
@@ -4,7 +4,6 @@
{-# LANGUAGE MultiParamTypeClasses #-}
module Main where
--- import Control.Monad
import Control.Monad.State
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS (concat, pack, unpack)
@@ -15,8 +14,6 @@ import Data.String
import qualified Data.Text
import Database.HDBC.Sqlite3
import Snap
--- import Snap.Core
--- import Snap.Snaplet
import Snap.Snaplet.Auth
import Snap.Snaplet.Auth.Backends.JsonFile
import Snap.Snaplet.Hdbc
@@ -24,6 +21,15 @@ import Snap.Snaplet.Session
import Snap.Snaplet.Session.Backends.CookieSession
import Snap.Util.FileServe
+-- User configurable
+
+guestUsers :: [String]
+guestUsers = ["bryllup"]
+adminUsers :: [String]
+adminUsers = ["admin"]
+
+-- Application setup
+
data App = App
{ _authLens :: Snaplet (AuthManager App)
, _sessLens :: Snaplet SessionManager
@@ -34,14 +40,12 @@ makeLenses [''App]
appInit :: SnapletInit App App
appInit = makeSnaplet "wishsys" "Wish list application" Nothing $ do
+ addAuthRoutes [ ("wishlist", wishViewHandler, guestUsers)
+ , ("admin", adminHandler, adminUsers) ]
addRoutes [ ("", serveFile "static/index.html")
- , ("wishlist", handleAsUser "bryllup" wishViewHandler)
- , ("insert", handleAsUser "admin" insertHandler)
+ , ("login/:ref", loginHandler)
, ("login", loginHandler)
- , ("logout", logoutHandler)
- , ("loginpage/:ref", loginPageHandler)
- , ("register", handleAsUser "bryllup" registerHandler)
- , ("admin", handleAsUser "admin" (serveFile "static/admin.html")) ]
+ , ("logout", logoutHandler) ]
_sesslens' <- nestSnaplet "session" sessLens $ initCookieSessionManager "config/site.txt" "_session" Nothing
_authlens' <- nestSnaplet "auth" authLens $ initJsonFileAuthManager defAuthSettings sessLens "users.json"
@@ -58,11 +62,22 @@ main = serveSnaplet defaultConfig appInit
-- Authentication --
--------------------
+-- Add routes that are authenticated by a user
+addAuthRoutes :: [(ByteString, Handler App App (), [String])] -> Initializer App App ()
+addAuthRoutes routeList = do
+ let authRouteList = map createAuthRoute routeList
+ addRoutes authRouteList
+
+-- FIXME: Support more than one user
+createAuthRoute :: (ByteString, Handler App App (), [String]) -> (ByteString, Handler App App ())
+createAuthRoute (routePath, handler, (user:users)) = (routePath, handleAsUser user handler)
+createAuthRoute (routePath, handler, []) = (routePath, handler)
+
redirectLogin :: MonadSnap m => m a
redirectLogin = do
req <- getRequest
let uri = rqURI req
- redirect $ BS.concat ["/loginpage", uri]
+ redirect $ BS.concat ["/login", uri]
-- Creates the login page
createLoginPage :: String -> String
@@ -79,13 +94,26 @@ createLoginPage referrer = "<html>" ++
"</html>"
-- Displays the login page, and preserve the referrer header
-loginPageHandler :: Handler App App ()
-loginPageHandler = do
+loginForm :: Handler App (AuthManager b) ()
+loginForm = do
ref <- getParam "ref"
case ref of
Nothing -> writeBS (BS.pack (createLoginPage ""))
Just val -> writeBS (BS.pack (createLoginPage (BS.unpack val)))
+
+-- Performs the actual login.
+loginHandler :: Handler App App ()
+loginHandler = with authLens $ do
+ loginUser "login" "password" (Just "remember") onFailure onSuccess
+ where onFailure _ = do loginForm
+ onSuccess = do
+ mu <- currentUser
+ case mu of
+ Just _ -> do ref <- getParam "referrer"
+ redirectTo ref
+ Nothing -> do loginForm -- Why does this happen?
+
-- Verifies user credentials and username before running handler
handleAsUser :: String -> (Handler App App ()) -> Handler App App ()
handleAsUser user fn = do
@@ -101,19 +129,7 @@ redirectTo :: MonadSnap m => Maybe ByteString -> m b
redirectTo dest = do
case dest of
Nothing -> redirect "/"
- Just _ -> redirect (fromJust dest)
-
--- Performs the actual login.
-loginHandler :: Handler App App ()
-loginHandler = with authLens $ do
- loginUser "login" "password" (Just "remember") onFailure onSuccess
- where onFailure _ = do redirectLogin
- onSuccess = do
- mu <- currentUser
- case mu of
- Just _ -> do ref <- getParam "referrer"
- redirectTo ref
- Nothing -> do redirectLogin -- Why does this happen?
+ Just uri -> redirect uri
logoutHandler :: Handler App App ()
logoutHandler = do
@@ -130,36 +146,74 @@ data Wish = Wish {
wishBought :: Integer
}
+pageHeader :: String -> String
+pageHeader header =
+ "<html>" ++
+ "<body>" ++
+ "<h1>" ++ header ++ "</h1>"
+
+pageFooter :: String
+pageFooter =
+ "<a href=\"/logout\">Logg ut</a>" ++
+ "</body>" ++
+ "</html>"
+
+render :: MonadSnap m => String -> m ()
+render text = writeBS (BS.pack text)
+
+adminHandler :: Handler App App ()
+adminHandler = do
+ render $ pageHeader "Administrer ønskeliste"
+ insertHandler
+ printWishList True
+ render insertForm
+ render pageFooter
+
+insertForm :: String
+insertForm =
+ "<h3>Sett inn nytt ønske</h3>" ++
+ "<form action=\"/admin\" method=\"post\">" ++
+ "<input type=\"text\" size=\"200\" name=\"what\" value=\"Skriv inn ønske\" /><br />" ++
+ "<input type=\"text\" size=\"200\" name=\"imgurl\" value=\"URL til bilde\" /><br />" ++
+ "<input type=\"text\" size=\"200\" name=\"store\" value=\"Navn på butikk + evt. url\" /><br />" ++
+ "<input type=\"text\" size=\"2\" name=\"amount\" value=\"0\" /><br />" ++
+ "<input type=\"submit\" value=\"Registrer\" />" ++
+ "</form>"
+
-- Insert handler deals with inserting new wishes into the database.
-insertHandler :: Handler App App ()
+insertHandler :: Handler App App () --MonadSnap m => m b -> Maybe ByteString -- Handler App App ()
insertHandler = do
- what <- getParam "what"
- imgurl <- getParam "imgurl"
- amount <- getParam "amount"
- store <- getParam "store"
- if what == Nothing || imgurl == Nothing || amount == Nothing || store == Nothing
- then writeBS "All three parameters must be set!"
- else do
- let whatText = BS.unpack (fromJust what)
- let urlText = BS.unpack (fromJust imgurl)
- let storeText = BS.unpack (fromJust store)
- let amountValue = read (BS.unpack (fromJust amount)) :: Integer
- insertWish (Wish 0 whatText urlText storeText amountValue 0)
- writeBS (BS.concat ["Inserted: '", (fromJust what), "'. Amount: '", (fromJust amount), "'"])
- redirect "/admin"
-
--- Register handler registers an update on a wish
-registerHandler :: Handler App App ()
-registerHandler = do
- wishid <- getParam "wishid"
- amount <- getParam "amount"
- if wishid == Nothing
- then (writeBS "id not given, aborting")
- else if amount == Nothing
- then (writeBS "amount not specified")
- else do registerPurchase (read (BS.unpack (fromJust wishid)) ::Integer)
- (read (BS.unpack (fromJust amount)) ::Integer)
- redirect "/wishlist"
+ whatParam <- getParam "what"
+ imgurlParam <- getParam "imgurl"
+ amountParam <- getParam "amount"
+ storeParam <- getParam "store"
+ case (whatParam, imgurlParam, amountParam, storeParam) of
+ (Just what,
+ Just imgurl,
+ Just amount,
+ Just store) -> do
+ let whatText = BS.unpack what
+ let urlText = BS.unpack imgurl
+ let storeText = BS.unpack store
+ let amountValue = read (BS.unpack amount) :: Integer
+ insertWish (Wish 0 whatText urlText storeText amountValue 0)
+ -- writeBS (BS.concat ["Inserted: '", what, "'. Amount: '", amount, "'"])
+ _ -> return ()
+
+
+-- Handler for the wishlist view. Registers any purchases and displays wish
+-- list.
+wishViewHandler :: Handler App App ()
+wishViewHandler = do
+ wishidParam <- getParam "wishid"
+ amountParam <- getParam "amount"
+ render $ pageHeader "Registre kjøpt ønske"
+ case (wishidParam, amountParam) of
+ (Just wishid, Just amount) -> do registerPurchase (read (BS.unpack wishid) ::Integer)
+ (read (BS.unpack amount) ::Integer)
+ printWishList False
+ _ -> do printWishList False
+ render pageFooter
-- Given a wish id and the amount of items, subtract this wish' remaining
-- amount.
@@ -172,44 +226,51 @@ registerPurchase wishid amount = do
if remaining - amount >= 0
then do
updateWish wishid (bought + amount)
- writeBS (BS.concat ["Har trukket ifra ", (fromString (show amount)), " stk. av type '", (fromString (wishName wish)), "'"])
- else writeBS "Ikke nok ønsker igjen!"
+ -- writeBS (BS.concat ["Har trukket ifra ", (fromString (show amount)), " stk. av type '", (fromString (wishName wish)), "'"])
+ else return () --writeBS "Ikke nok ønsker igjen!"
-- Display all wishes and a form for registering purchases
-wishViewHandler :: Handler App App ()
-wishViewHandler = do
+printWishList :: Bool -> Handler App App ()
+printWishList admin = do
wishList <- getWishes
- writeBS "<html>"
- writeBS "<h1>Ønskeliste</h1>"
- writeBS "<table border=\"1\">"
- writeBS "<tr><th>Hva</th><th>Bilde</th><th>Butikk</th><th>Antall</th><th>Registrer</th></tr>"
- writeBS (fromString (concat (map formatWishEntry wishList)))
- writeBS "</table>"
- writeBS "<a href=\"/logout\">Logg ut</a>"
- writeBS "</html>"
+ render $ formatWishList wishList admin
+
+formatWishList :: [Wish] -> Bool -> String
+formatWishList wishList admin =
+ "<h3>Ønskeliste</h3>" ++
+ "<table border=\"1\">" ++
+ "<tr><th>Hva</th><th>Bilde</th><th>Butikk</th>" ++
+ userHeaders ++
+ "</tr>" ++
+ wishes ++
+ "</table>"
+ where wishes = concat (map (\x -> formatWishEntry x admin) wishList)
+ userHeaders = if admin then "" else "<th>Antall</th><th>Registrer</th>"
-- Helper method for formatting a wish entry in the wish view.
-formatWishEntry :: Wish -> String
-formatWishEntry (Wish wishid name url store amount bought) =
+formatWishEntry :: Wish -> Bool -> String
+formatWishEntry (Wish wishid name url store amount bought) admin =
"<tr>" ++
"<td>" ++ name ++ "</td>" ++
"<td><a href=\"" ++ url ++ "\"><img src=\"" ++ url ++ "\" width=\"100\" height=\"100\" /></a></td>" ++
"<td>" ++ store ++ "</td>" ++
- "<td>" ++ (show remaining) ++ "</td>" ++
- "<td>" ++
- "<form action=\"register\" method=\"post\">" ++
- "<input type=\"text\" size=\"2\" name=\"amount\" value=\"0\" />" ++
- "<input type=\"hidden\" name=\"wishid\" value=\"" ++ (show wishid) ++ "\" />" ++
- "<input type=\"submit\" value=\"Registrer\" />" ++
- "</form>" ++
- "</td>" ++
+ userHeaders ++
"</tr>"
- where remaining = amount - bought
-
+ where remaining = amount - bought
+ userHeaders = if admin
+ then ""
+ else "<td>" ++ (show remaining) ++ "</td>" ++
+ "<td>" ++
+ "<form action=\"/wishlist\" method=\"post\">" ++
+ "<input type=\"text\" size=\"2\" name=\"amount\" value=\"0\" />" ++
+ "<input type=\"hidden\" name=\"wishid\" value=\"" ++ (show wishid) ++ "\" />" ++
+ "<input type=\"submit\" value=\"Registrer\" />" ++
+ "</form>" ++
+ "</td>"
-------------------------------------------
--- Functions for interacting with database
-------------------------------------------
+---------------------------------------------
+-- Functions for interacting with database --
+---------------------------------------------
-- Get a list of all wishes
getWishes :: HasHdbc m c s => m [Wish]

No commit comments for this range

Something went wrong with that request. Please try again.