From 05f2826745a9eddd85f15652bcae8be7e0714bc6 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 30 Nov 2016 21:22:35 +0100 Subject: [PATCH] slowly working its way forward --- Handler/Login.hs | 5 +- Makefile | 9 ++-- src/Activate.purs | 83 +++++++++++++++++++++++++++++ src/{Main.js => Common.js} | 13 +++++ src/Common.purs | 94 +++++++++++++++++++++++++++++++++ src/Login.purs | 105 +++++++++++++++++++++++++++++++++++++ src/Main.purs | 93 -------------------------------- templates/activate.hamlet | 12 ++--- templates/login.hamlet | 10 ++-- 9 files changed, 314 insertions(+), 110 deletions(-) create mode 100644 src/Activate.purs rename src/{Main.js => Common.js} (53%) create mode 100644 src/Common.purs create mode 100644 src/Login.purs delete mode 100644 src/Main.purs diff --git a/Handler/Login.hs b/Handler/Login.hs index 4cf5b7b..a626650 100755 --- a/Handler/Login.hs +++ b/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) diff --git a/Makefile b/Makefile index 356a819..7dc92e4 100644 --- a/Makefile +++ b/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 - pulp browserify -O > ./static/js/purs.js - -all: hsbuild pursbuild +pursbuild: pursdeps + pulp browserify -m Login -O -t ./static/js/purs_login.js + pulp browserify -m Activate -O -t ./static/js/purs_activate.js diff --git a/src/Activate.purs b/src/Activate.purs new file mode 100644 index 0000000..b011267 --- /dev/null +++ b/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" diff --git a/src/Main.js b/src/Common.js similarity index 53% rename from src/Main.js rename to src/Common.js index 4a14115..a89866f 100644 --- a/src/Main.js +++ b/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); + }; + }; +}; diff --git a/src/Common.purs b/src/Common.purs new file mode 100644 index 0000000..de3e12f --- /dev/null +++ b/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 diff --git a/src/Login.purs b/src/Login.purs new file mode 100644 index 0000000..31bf6d6 --- /dev/null +++ b/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 diff --git a/src/Main.purs b/src/Main.purs deleted file mode 100644 index f1a7f33..0000000 --- a/src/Main.purs +++ /dev/null @@ -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 diff --git a/templates/activate.hamlet b/templates/activate.hamlet index f9be960..48acdfd 100755 --- a/templates/activate.hamlet +++ b/templates/activate.hamlet @@ -5,14 +5,14 @@ $newline always