slowly working its way forward

This commit is contained in:
nek0 2016-11-30 21:22:35 +01:00
parent 5521e1a01d
commit 05f2826745
9 changed files with 314 additions and 110 deletions

View File

@ -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)

View File

@ -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

83
src/Activate.purs Normal file
View File

@ -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"

View File

@ -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);
};
};
};

94
src/Common.purs Normal file
View File

@ -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

105
src/Login.purs Normal file
View File

@ -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

View File

@ -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

View File

@ -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>
<p id="progress">
<div .form-group .optional>
<input id="activate" type="submit" value="Activate" data-token="#{token}" data-salt="#{hexSalt}">
<input #password2 type="password" required>
<p #progress>
<div .form-group .optional>
<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">

View File

@ -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>
<button .btn .btn-default #login type="submit">Login
<div #progress>
<div .form-group .optional>
<button .btn .btn-default #login>Login
<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/login.js" type="text/javascript">
<!--<script src="/static/js/jsSHA.js" type="text/javascript">-->
<script src="/static/js/purs_login.js" type="text/javascript">