Permalink
Browse files

Port JCU app to the latest digestive-functors

  • Loading branch information...
1 parent 64a33f8 commit fff2cb87deea2790913a3a63a920c69fa2ce389d @norm2782 norm2782 committed Sep 10, 2012
Showing with 134 additions and 91 deletions.
  1. +11 −9 JCU.cabal
  2. +76 −60 src/Application.hs
  3. +40 −16 src/JCU/Templates.hs
  4. +7 −6 src/Main.hs
View
@@ -25,7 +25,7 @@ Extra-Source-Files: README.md, FUTURE-WORK.md
Source-repository head
Type: git
- Location: https://github.com/norm2782/JCU.git
+ Location: https://github.com/UU-ComputerScience/JCU
Flag development
Description: Whether to build the server in development (interpreted) mode
@@ -39,14 +39,15 @@ Executable jcu
aeson >= 0.6,
attoparsec >= 0.9,
base >= 4 && < 5,
- blaze-html >= 0.4.1,
+ blaze-html >= 0.5,
+ blaze-markup >= 0.5,
bytestring >= 0.9,
containers >= 0.4,
data-lens >= 2,
data-lens-template >= 2,
- digestive-functors >= 0.2 && < 0.3,
- digestive-functors-blaze >= 0.2.1 && < 0.3,
- digestive-functors-snap >= 0.1.3.1 && < 0.3,
+ digestive-functors == 0.5.*,
+ digestive-functors-blaze == 0.5.*,
+ digestive-functors-snap == 0.5.*,
email-validate >= 0.2.6,
HDBC >= 2.2,
HDBC-postgresql >= 2.1,
@@ -55,10 +56,11 @@ Executable jcu
mtl >= 2.0,
NanoProlog >= 0.3,
resource-pool-catchio >= 0.2 && < 0.3,
- snap >= 0.8,
- snap-core >= 0.8,
- snap-server >= 0.8,
- snaplet-hdbc >= 0.8,
+ snap == 0.9.*,
+ snap-core == 0.9.*,
+ snap-loader-static == 0.9.*,
+ snap-server == 0.9.*,
+ snaplet-hdbc == 0.9.*,
text >= 0.11,
time >= 1.1 && < 1.5,
transformers >= 0.2,
View
@@ -43,12 +43,11 @@ import Snap.Snaplet.Hdbc
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Backends.CookieSession
import Snap.Util.FileServe
-import Text.Blaze
import qualified Text.Blaze.Html5 as H
-import Text.Blaze.Renderer.Utf8 (renderHtml)
+import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Digestive
-import Text.Digestive.Blaze.Html5
-import Text.Digestive.Forms.Snap
+import qualified Text.Digestive.Form as DF
+import Text.Digestive.Snap hiding (method)
import qualified Text.Email.Validate as E
@@ -121,16 +120,16 @@ loginH :: AppHandler ()
loginH = withSession sessLens $ do
loggedIn <- with authLens isLoggedIn
when loggedIn $ redirect "/"
- res <- eitherSnapForm loginForm "login-form"
+ res <- runForm "login-form" loginForm
case res of
- Left form' -> do
+ (view, Nothing) -> do
didFail <- with sessLens $ do
failed <- getFromSession "login-failed"
deleteFromSession "login-failed"
commitSession
return failed
- blaze $ template $ loginHTML (isJust didFail) form'
- Right (FormUser e p r) -> do
+ blaze $ template $ loginHTML (isJust didFail) view
+ (_, Just (FormUser e p r)) -> do
loginRes <- with authLens $
loginByUsername (DT.encodeUtf8 e)
(ClearText $ DT.encodeUtf8 p) r
@@ -146,16 +145,16 @@ signupH :: AppHandler ()
signupH = do
loggedIn <- with authLens isLoggedIn
when loggedIn $ redirect "/"
- res <- eitherSnapForm registrationForm "registration-form"
+ res <- runForm "registration-form" registrationForm
case res of
- Left form' -> do
+ (view, Nothing) -> do
exists <- with sessLens $ do
failed <- getFromSession "username-exists"
deleteFromSession "username-exists"
commitSession
return failed
- blaze $ template (signupHTML (isJust exists) form')
- Right (FormUser e p _) -> do
+ blaze $ template (signupHTML (isJust exists) view)
+ (_, Just (FormUser e p _)) -> do
_ <- with authLens (createUser e (DT.encodeUtf8 p)) `catch` hndlExcptn
redirect "/"
where hndlExcptn :: SomeException -> AppHandler AuthUser
@@ -284,7 +283,7 @@ substH = restrict forbiddenH $ do
-------------------------------------------------------------------------------
-- View rendering
-blaze :: Reader AuthState Html -> AppHandler ()
+blaze :: Reader AuthState H.Html -> AppHandler ()
blaze htmlRdr = do
modifyResponse $ addHeader "Content-Type" "text/html; charset=UTF-8"
li <- with authLens isLoggedIn
@@ -305,63 +304,80 @@ data FormUser = FormUser
, remember :: Bool }
deriving Show
-isEmail :: Monad m => Validator m Html Text
+{-isEmail :: Monad m => Validator m Html Text-}
+isEmail :: Monad m => Form H.Html m Text -> Form H.Html m Text
isEmail = check "Invalid email address" (E.isValid . DT.unpack)
-longPwd :: Monad m => Validator m Html Text
+{-longPwd :: Monad m => Validator m Html Text-}
+longPwd :: Monad m => Form H.Html m Text -> Form H.Html m Text
longPwd = check "Password needs to be at least six characters long"
$ \xs -> DT.length xs >= 6
-isNonEmpty :: Monad m => Validator m Html Text
+{-isNonEmpty :: Monad m => Validator m Html Text-}
+isNonEmpty :: Monad m => Form H.Html m Text -> Form H.Html m Text
isNonEmpty = check "Field must not be empty" $ not . DT.null
-identical :: Validator AppHandler Html (Text, Text)
+{-identical :: Validator AppHandler Html (Text, Text)-}
+identical :: Monad m => Form H.Html m (Text, Text) -> Form H.Html m (Text, Text)
identical = check "Field values must be identical" (uncurry (==))
-loginForm :: Form AppHandler SnapInput Html BlazeFormHtml FormUser
-loginForm = (\e p r _ -> FormUser e p r)
- <$> mapViewHtml H.div (
- label "Email address: "
- ++> inputText Nothing `validate` isEmail
- <++ errors)
- <*> mapViewHtml H.div (
- label "Password: "
- ++> inputPassword False `validate` longPwd
- <++ errors)
- <*> mapViewHtml H.div (
- label "Remember me?"
- ++> inputCheckBox True)
- <*> mapViewHtml H.div (
- submit "Login")
-
-registrationForm :: Form AppHandler SnapInput Html BlazeFormHtml FormUser
-registrationForm = (\ep pp _ -> FormUser (fst ep) (fst pp) False)
+{-loginForm :: Form AppHandler SnapInput Html BlazeFormHtml FormUser-}
+{-loginForm = (\e p r _ -> FormUser e p r)-}
+ {-<$> mapViewHtml H.div (-}
+ {-label "Email address: "-}
+ {-++> inputText Nothing `validate` isEmail-}
+ {-<++ errors)-}
+ {-<*> mapViewHtml H.div (-}
+ {-label "Password: "-}
+ {-++> inputPassword False `validate` longPwd-}
+ {-<++ errors)-}
+ {-<*> mapViewHtml H.div (-}
+ {-label "Remember me?"-}
+ {-++> inputCheckBox True)-}
+ {-<*> mapViewHtml H.div (-}
+ {-submit "Login")-}
+
+loginForm :: Form H.Html AppHandler FormUser
+loginForm = FormUser
+ <$> "email" DF..: isEmail (text Nothing)
+ <*> "password" DF..: longPwd (text Nothing)
+ <*> "remember" DF..: bool Nothing
+
+{-registrationForm :: Form AppHandler SnapInput Html BlazeFormHtml FormUser-}
+{-registrationForm = (\ep pp _ -> FormUser (fst ep) (fst pp) False)-}
+ {-<$> ((,)-}
+ {-<$> mapViewHtml H.div (-}
+ {-label "Email address: "-}
+ {-++> inputText Nothing `validate` isEmail-}
+ {-<++ errors)-}
+ {-<*> mapViewHtml H.div (-}
+ {-label "Email address (confirmation): "-}
+ {-++> inputText Nothing `validate` isEmail-}
+ {-<++ errors))-}
+ {-`validate` identical-}
+ {-<++ errors-}
+ {-<*> ((,)-}
+ {-<$> mapViewHtml H.div (-}
+ {-label "Password: "-}
+ {-++> inputPassword False `validate` longPwd-}
+ {-<++ errors)-}
+ {-<*> mapViewHtml H.div (-}
+ {-label "Password (confirmation): "-}
+ {-++> inputPassword False `validate` longPwd-}
+ {-<++ errors))-}
+ {-`validate` identical-}
+ {-<++ errors-}
+ {-<*> mapViewHtml H.div (-}
+ {-submit "Register")-}
+
+registrationForm :: Form H.Html AppHandler FormUser
+registrationForm = (\ep pp -> FormUser (fst ep) (fst pp) False)
<$> ((,)
- <$> mapViewHtml H.div (
- label "Email address: "
- ++> inputText Nothing `validate` isEmail
- <++ errors)
- <*> mapViewHtml H.div (
- label "Email address (confirmation): "
- ++> inputText Nothing `validate` isEmail
- <++ errors))
- `validate` identical
- <++ errors
- <*> ((,)
- <$> mapViewHtml H.div (
- label "Password: "
- ++> inputPassword False `validate` longPwd
- <++ errors)
- <*> mapViewHtml H.div (
- label "Password (confirmation): "
- ++> inputPassword False `validate` longPwd
- <++ errors))
- `validate` identical
- <++ errors
- <*> mapViewHtml H.div (
- submit "Register")
-
-
+ <$> "email1" DF..: isEmail (text Nothing)
+ <*> "email2" DF..: isEmail (text Nothing))
+ <*> ((,)
+ <$> "password1" DF..: longPwd (text Nothing)
+ <*> "password2" DF..: longPwd (text Nothing))
-------------------------------------------------------------------------------
-- Database interaction
View
@@ -5,11 +5,11 @@ module JCU.Templates where
import Control.Monad
import Control.Monad.Reader
import Data.Text (Text)
-import Text.Blaze.Html5 (Html, AttributeValue, (!))
+import Text.Blaze.Html5 (Html, (!))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
-import Text.Blaze.Internal (HtmlM(..))
import Text.Digestive.Blaze.Html5
+import qualified Text.Digestive.View as V
-------------------------------------------------------------------------------
@@ -80,20 +80,52 @@ header = do
-- Replaces the signup.tpl file
-signupHTML :: Bool -> FormHtml (HtmlM a) -> Reader AuthState Html
-signupHTML exists frm = return $
+signupHTML :: Monad m => Bool -> V.View Html -> m Html
+signupHTML exists view = return $
H.div ! A.id "home-view" $ do
H.h1 $ H.toHtml ("Please sign up" :: Text)
when exists $ H.h2 "Username is already taken"
- showForm "/signup" frm
+ form view "/signup" $ do
+ registrationFormView view
+ H.div $ inputSubmit "Sign up!"
+
+registrationFormView :: V.View v -> Html
+registrationFormView view = do
+ H.div $ do
+ label "email1" view "Email address: "
+ inputText "email1" view
+ H.div $ do
+ label "email2" view "Email address (confirmation): "
+ inputText "email2" view
+ H.div $ do
+ label "password1" view "Password: "
+ inputPassword "password1" view
+ H.div $ do
+ label "password2" view "Password (confirmation): "
+ inputPassword "password2" view
-- Replaces the login.tpl file
-loginHTML :: Bool -> FormHtml (HtmlM a) -> Reader AuthState Html
-loginHTML loginFailed frm = return $
+{-loginHTML :: Bool -> FormHtml (HtmlM a) -> Reader AuthState Html-}
+loginHTML :: Monad m => Bool -> V.View Html -> m Html
+loginHTML loginFailed view = return $
H.div ! A.id "home-view" $ do
H.h1 $ H.toHtml ("Please log in" :: Text)
when loginFailed $ H.h2 "Incorrect login credentials"
- showForm "/login" frm
+ form view "/login" $ do
+ loginFormView view
+ H.div $ inputSubmit "Log in"
+
+loginFormView :: V.View Html -> Html
+loginFormView view = do
+ H.div $ do
+ label "email" view "Email address: "
+ inputText "email" view
+ H.div $ do
+ label "password" view "Password: "
+ inputPassword "password" view
+ H.div $ do
+ label "remember" view "Remember me?"
+ inputCheckbox "remember" view
mainHTML :: Html -> Reader AuthState Html
mainHTML left = return $ do
@@ -118,14 +150,6 @@ interpreterHTML = mainHTML $ do
H.div ! A.id "output" $
H.toHtml ("Please enter a query" :: Text)
-showForm :: AttributeValue -> FormHtml (HtmlM a) -> Html
-showForm act frm =
- let (formHtml', enctype) = renderFormHtml frm
- in H.form ! A.enctype (H.toValue $ show enctype) ! A.method "post"
- ! A.action act $ do
- _ <- formHtml'
- return ()
-
index :: Reader AuthState Html
index = mainHTML $ do
H.h2 "Proof Tree"
View
@@ -11,15 +11,16 @@ import qualified Data.Text as T
import Snap.Http.Server
import Snap.Snaplet
+import Snap.Snaplet.Config
import Snap.Core
import System.IO
#ifdef DEVELOPMENT
-import Snap.Loader.Devel
+import Snap.Loader.Dynamic
#else
-import Snap.Loader.Prod
+import Snap.Loader.Static
#endif
@@ -86,7 +87,7 @@ main = do
--
-- This action is only run once, regardless of whether development or
-- production mode is in use.
-getConf :: IO (Config Snap ())
+getConf :: IO (Config Snap AppConfig)
getConf = commandLineConfig defaultConfig
@@ -103,9 +104,9 @@ getConf = commandLineConfig defaultConfig
--
-- This sample doesn't actually use the config passed in, but more
-- sophisticated code might.
-getActions :: Config Snap () -> IO (Snap (), IO ())
-getActions _ = do
- (msgs, site, cleanup) <- runSnaplet jcu
+getActions :: Config Snap AppConfig -> IO (Snap (), IO ())
+getActions conf = do
+ (msgs, site, cleanup) <- runSnaplet (appEnvironment =<< getOther conf) jcu
hPutStrLn stderr $ T.unpack msgs
return (site, cleanup)

0 comments on commit fff2cb8

Please sign in to comment.