slowly working its way forward

Handler/Login.hs

@@ -31,6 +31,7 @@ import Data.Text.Encoding (encodeUtf8)
 import Data.Serialize (encode)
 import Data.Maybe
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as BC
 import Data.Aeson.Types
 
 data Credentials = Credentials
@@ -72,7 +73,7 @@ postLoginR = do
             queriedUser <- runDB $ getJust (fromJust savedUserId)
             let salted = userSalted queriedUser
             let hexSalted = toHex salted
-            let expected = hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted)
+            let expected = hmacSHA3 (tokenToken token) (encodeUtf8 hexSalted)
             if
               fromHex' (T.unpack hexResponse) == expected
               then do
@@ -120,4 +121,4 @@ hmacSHA1 keyData msgData =
   in encode sha1
 
 hmacSHA3 :: B.ByteString -> B.ByteString -> B.ByteString
-hmacSHA3 key msg = B.pack $ show $ hmacGetDigest (hmac key msg :: HMAC SHA3_512)
+hmacSHA3 key msg = BC.pack $ show $ hmacGetDigest (New.hmac key msg :: HMAC SHA3_512)

Makefile

@@ -1,3 +1,5 @@
+all:	hsbuild pursbuild
+
 clean:
 	cabal clean
 	rm -r bower_components
@@ -18,7 +20,6 @@ cryptojs:
 	npm install react
 	npm install react-dom
 
-pursbuild:	purdeps
+pursbuild:	pursdeps
-	pulp browserify -O > ./static/js/purs.js
+	pulp browserify -m Login -O -t ./static/js/purs_login.js
-
+	pulp browserify -m Activate -O -t ./static/js/purs_activate.js
-all:	hsbuild pursbuild

src/Activate.purs

@@ -0,0 +1,83 @@
+module Activate where
+
+import Prelude
+import Control.Monad.Aff
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+import Control.Monad.Eff.JQuery
+import Control.Monad.Except
+
+import DOM (DOM)
+
+import Data.Function.Uncurried (Fn2, runFn2)
+import Data.Maybe
+import Data.Either
+import Data.Tuple (Tuple(..))
+import Data.Unit
+
+import Data.Argonaut as A
+import Data.Argonaut.Decode
+
+import React as R
+import React.DOM as R
+import React.DOM.Props as RP
+import ReactDOM as RDOM
+
+import DOM.Node.Element
+
+import Network.HTTP.Affjax
+
+import Data.FormURLEncoded as UE
+
+import Partial.Unsafe
+
+import Common
+
+-- main :: forall e. Eff (console :: CONSOLE | e) Unit
+-- main = do
+--   log "Hello sailor!"
+
+main :: forall eff. Eff ( ajax :: AJAX
+                        , dom :: DOM
+                        , console :: CONSOLE
+                        | eff
+                        ) Unit
+main =
+  ready $ do
+    activate <- select "#activate"
+    on "click" (onActivateClick activate) activate
+
+onActivateClick
+  :: forall eff. JQuery
+  -> JQueryEvent
+  -> JQuery
+  -> Eff (dom :: DOM
+    , console :: CONSOLE
+    , ajax :: AJAX
+    | eff
+    ) Unit
+onActivateClick activate ev _ = unsafePartial $ do
+  preventDefault ev
+  token <- getAttr "data-token" activate
+  salt <- getAttr "data-salt" activate
+  fpassword1 <- getValue =<< select "#password1"
+  fpassword2 <- getValue =<< select "#password2"
+  let password1 = fromForeign fpassword1
+      password2 = fromForeign fpassword2
+  if not (isNothing password1 && isNothing password2)
+    then
+      if password1 == password2
+        then do
+          progress "Salting password"
+          let salted = runFn2 hmacSha3 (fromJust password1) salt
+          progress "Requesting account activation..."
+          let dat = UE.encode (UE.fromArray [ Tuple "salted" (Just salted) ]) :: String
+          _ <- runAff
+              (\e -> fail Activate $ show e)
+              (\x -> welcome x.response Activate)
+              $ post ("/activate/" <> token) dat
+          pure unit
+        else
+          fail Activate "Passwords must match"
+    else
+      fail Activate "Passwords error"

src/Common.js

@@ -8,3 +8,16 @@ exports.hmacSha3 = function(msg, key) {
 	var hmac  = CryptoJS.HmacSHA3(wamsg, wakey);
 	return hmac.toString();
 }
+
+exports.setLocation = function(newLoc) {
+	window.location = newloc;
+	return null;
+}
+
+exports.getAttr = function(attr) {
+    return function(ob) {
+        return function() {
+            ob.attr(attr);
+        };
+    };
+};

src/Common.purs

@@ -0,0 +1,94 @@
+module Common where
+
+import Prelude
+import Control.Monad.Aff
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+import Control.Monad.Eff.JQuery
+import Control.Monad.Except
+
+import DOM (DOM)
+import Data.Function.Uncurried (Fn2, runFn2)
+import Data.Maybe
+import Data.Either
+import Data.Tuple (Tuple(..))
+import Data.Foreign as F
+import Data.Unit
+import Data.Argonaut as A
+import Data.Argonaut.Decode
+import React as R
+import React.DOM as R
+import React.DOM.Props as RP
+import ReactDOM as RDOM
+import DOM.Node.Element
+
+import Network.HTTP.Affjax
+
+import Data.FormURLEncoded as UE
+
+import Partial.Unsafe
+
+data Elem
+  = Login
+  | Activate
+
+welcome :: forall eff. A.Json -> Elem -> Eff (dom :: DOM | eff) Unit
+welcome j elem = do
+  let eitherWelcome = decodeJson j
+  case eitherWelcome of
+    Left e ->
+      fail elem e
+    Right (Welcome welc) -> do
+      progress "welcome to Eidolon"
+      setLocation welc.link
+
+progress :: forall eff. String -> Eff (dom :: DOM | eff) Unit
+progress s = do
+  setText s =<< select "#progress"
+
+fail :: forall eff. Elem -> String -> Eff (dom :: DOM | eff) Unit
+fail Login s = do
+  progress s
+  setProp "disabled" false <$> select ".login input"
+  display =<< select "#login"
+fail Activate s = do
+  progress s
+  setProp "disabled" false <$> select ".activate input"
+  display =<< select "#activate"
+
+data Challenge = Challenge
+  { salt :: String
+  , token :: String
+  }
+
+instance decodeJsonChallenge :: DecodeJson Challenge where
+  decodeJson j = do
+    obj <- decodeJson j
+    salt <- obj .? "salt"
+    token <- obj .? "token"
+    pure $ Challenge { salt, token }
+
+data Welcome = Welcome
+  { link :: String
+  }
+
+instance decodeJsonWelcome :: DecodeJson Welcome where
+  decodeJson j = do
+    obj <- decodeJson j
+    link <- obj .? "welcome"
+    pure $ Welcome { link }
+
+fromForeign :: F.Foreign -> Maybe String
+fromForeign f = case runExcept (F.readString f) of
+  Left e -> Nothing
+  Right s -> Just s
+
+foreign import hmacSha3 :: Fn2 String String String
+
+foreign import setLocation :: forall eff. String -> Eff (dom :: DOM | eff) Unit
+
+foreign import getAttr
+  :: forall eff a
+   . String
+  -> JQuery
+  -> Eff (dom :: DOM | eff) String

src/Login.purs

@@ -0,0 +1,105 @@
+module Login where
+
+import Prelude
+import Control.Monad.Aff
+import Control.Monad.Eff (Eff)
+import Control.Monad.Eff.Console (CONSOLE, log)
+import Control.Monad.Eff.JQuery
+import Control.Monad.Except
+
+import DOM (DOM)
+
+import Data.Function.Uncurried (Fn2, runFn2)
+import Data.Maybe
+import Data.Either
+import Data.Tuple (Tuple(..))
+import Data.Unit
+
+import Data.Argonaut as A
+import Data.Argonaut.Decode
+
+import React as R
+import React.DOM as R
+import React.DOM.Props as RP
+import ReactDOM as RDOM
+
+import DOM.Node.Element
+
+import Network.HTTP.Affjax
+
+import Data.FormURLEncoded as UE
+
+import Partial.Unsafe
+
+import Common
+
+-- main :: forall e. Eff (console :: CONSOLE | e) Unit
+-- main = do
+--   log "Hello sailor!"
+
+main :: forall eff. Eff ( ajax :: AJAX
+                        , dom :: DOM
+                        , console :: CONSOLE
+                        | eff
+                        ) Unit
+main =
+  ready $ do
+    log "logging in"
+    login <- select "#login"
+    on "click" (onLoginClick login) login
+
+onLoginClick
+  :: forall eff. JQuery
+  -> JQueryEvent
+  -> JQuery
+  -> Eff ( dom :: DOM
+    , console :: CONSOLE
+    , ajax :: AJAX
+    | eff
+    ) Unit
+onLoginClick login ev x = unsafePartial $ do
+  log "click!"
+  preventDefault ev
+  hide login
+  setProp "disabled" true <$> select ".login input"
+  fusername <- getValue =<< select "#username"
+  fpassword <- getValue =<< select "#password"
+  let username = fromForeign fusername
+      password = fromForeign fpassword
+  if not (isNothing username && isNothing password)
+    then do
+      progress "Obtaining Challenge..."
+      let data1 = UE.encode (UE.fromArray $ [ Tuple "username" username ]) :: String
+      _ <- runAff
+          (\e -> fail Login $ show e)
+          (\x -> resp1Success (fromJust password) x.response)
+          $ post "/login" data1
+      log "success so far"
+    else
+      log "error"
+
+resp1Success :: forall eff. String
+  -> A.Json
+  -> Eff ( dom :: DOM
+    , console :: CONSOLE
+    , ajax :: AJAX
+    | eff
+    ) Unit
+resp1Success pass j = do
+  log $ show j
+  let eitherChallenge = decodeJson j
+  case eitherChallenge of
+    Left e ->
+      fail Login e
+    Right (Challenge challenge) -> do
+      progress "HMAC 1"
+      let salted = runFn2 hmacSha3 pass challenge.salt
+      progress "HMAC 2"
+      let response = runFn2 hmacSha3 salted challenge.token
+      progress "sending response"
+      let data2 = UE.encode (UE.fromArray $ [ Tuple "token" (Just challenge.token), Tuple "response" (Just response) ]) :: String
+      _ <- runAff
+          (\e -> fail Login $ show e)
+          (\x -> welcome x.response Login)
+          $ post "/login" data2
+      pure unit

src/Main.purs

@@ -1,93 +0,0 @@
-module Main where
-
-import Prelude
-import Control.Monad.Eff (Eff)
-import Control.Monad.Eff.Console (CONSOLE, log)
-import Control.Monad.Eff.JQuery
-import Control.Monad.Except
-
-import DOM (DOM)
-
-import Data.Function.Uncurried (Fn2, runFn2)
-import Data.Maybe
-import Data.Either
-import Data.Tuple (Tuple(..))
-import Data.Foreign
-
-import Data.Argonaut as A
-import Data.Argonaut.Decode
-
-import React as R
-import React.DOM as R
-import React.DOM.Props as RP
-import ReactDOM as RDOM
-
-import Network.HTTP.Affjax (get, post)
-
-import Data.FormURLEncoded as UE
-
--- main :: forall e. Eff (console :: CONSOLE | e) Unit
--- main = do
---   log "Hello sailor!"
-
-main :: forall eff. Eff ( dom :: DOM
-                        , console :: CONSOLE
-                        | eff
-                        ) Unit
-main =
-  ready $ do
-    hide <$> select "#login"
-    setProp "disabled" true <$> select ".login input"
-
-    fusername <- getValue =<< select "#username"
-    fpassword <- getValue =<< select "#password"
-
-    let username = fromForeign fusername
-        password = fromForeign fpassword
-
-    if not (isNothing username && isNothing password)
-      then do
-
-        progress "Obtaining Challenge..."
-
-        let data1 = UE.encode (UE.fromArray $ [ Tuple "username" username ]) :: String
-
-        -- resp1 <- post "/login" data1
-        -- (Challenge challenge) <- decodeJson resp1.response
-
-        progress "HMAC 1"
-
-        -- let salted = runFn2 hmacSha3 (fromJust password) challenge.salt
-
-        log "bla"
-      else
-        log "error"
-
-progress :: forall eff. String -> Eff (dom :: DOM | eff) Unit
-progress s = do
-  setText s =<< select "#progress"
-
-fail :: forall eff. String -> Eff (dom :: DOM | eff) Unit
-fail s = do
-  progress s
-  setProp "disabled" false <$> select ".login input"
-  display =<< select "#login"
-
-data Challenge = Challenge
-  { salt :: String
-  , token :: String
-  }
-
-instance decodeJsonChallenge :: DecodeJson Challenge where
-  decodeJson j = do
-    obj <- decodeJson j
-    salt <- obj .? "salt"
-    token <- obj .? "token"
-    pure $ Challenge { salt, token }
-
-fromForeign :: Foreign -> Maybe String
-fromForeign f = case runExcept (readString f) of
-  Left e -> Nothing
-  Right s -> Just s
-
-foreign import hmacSha3 :: Fn2 String String String

templates/activate.hamlet

@@ -5,14 +5,14 @@ $newline always
   <form>
     <div .form-group .required>
       <label for="password1">Password:
-      <input id="password1" type="password" required>
+      <input #password1 type="password" required>
     <div .form-group .required>
       <label for="password2">Confirm your password:
-      <input id="password2" type="password" required>
+      <input #password2 type="password" required>
-    <p id="progress">
+    <p #progress>
-    <div .form-group .optional>
+  <div .form-group .optional>
-      <input id="activate" type="submit" value="Activate" data-token="#{token}" data-salt="#{hexSalt}">
+    <button #activate data-token="#{token}" data-salt="#{hexSalt}">Activate
 
   <script src="/static/js/jquery.min.js" type="text/javascript">
   <script src="/static/js/jsSHA.js" type="text/javascript">
-  <script src="/static/js/activate.js" type="text/javascript">
+  <script src="/static/js/purs_activate.js" type="text/javascript">

templates/login.hamlet

@@ -9,12 +9,12 @@ $newline always
     <div .form-group .required>
       <label for="password">Password:
       <input .form-control #password type="password" required>
-    <div .form-group .optional>
+  <div .form-group .optional>
-      <button .btn .btn-default #login type="submit">Login
+    <button .btn .btn-default #login>Login
-    <div #progress>
+  <div #progress>
 
   <a href=@{ReactivateR}>Forgot your Password?
 
   <script src="/static/js/jquery.min.js" type="text/javascript">
-  <script src="/static/js/jsSHA.js" type="text/javascript">
+  <!--<script src="/static/js/jsSHA.js" type="text/javascript">-->
-  <script src="/static/js/login.js" type="text/javascript">
+  <script src="/static/js/purs_login.js" type="text/javascript">