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.Serialize (encode)
import Data.Maybe import Data.Maybe
import qualified Data.ByteString as B import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import Data.Aeson.Types import Data.Aeson.Types
data Credentials = Credentials data Credentials = Credentials
@ -72,7 +73,7 @@ postLoginR = do
queriedUser <- runDB $ getJust (fromJust savedUserId) queriedUser <- runDB $ getJust (fromJust savedUserId)
let salted = userSalted queriedUser let salted = userSalted queriedUser
let hexSalted = toHex salted let hexSalted = toHex salted
let expected = hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted) let expected = hmacSHA3 (tokenToken token) (encodeUtf8 hexSalted)
if if
fromHex' (T.unpack hexResponse) == expected fromHex' (T.unpack hexResponse) == expected
then do then do
@ -120,4 +121,4 @@ hmacSHA1 keyData msgData =
in encode sha1 in encode sha1
hmacSHA3 :: B.ByteString -> B.ByteString -> B.ByteString 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: clean:
cabal clean cabal clean
rm -r bower_components rm -r bower_components
@ -18,7 +20,6 @@ cryptojs:
npm install react npm install react
npm install react-dom 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

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); var hmac = CryptoJS.HmacSHA3(wamsg, wakey);
return hmac.toString(); 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> <form>
<div .form-group .required> <div .form-group .required>
<label for="password1">Password: <label for="password1">Password:
<input id="password1" type="password" required> <input #password1 type="password" required>
<div .form-group .required> <div .form-group .required>
<label for="password2">Confirm your password: <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/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/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> <div .form-group .required>
<label for="password">Password: <label for="password">Password:
<input .form-control #password type="password" required> <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? <a href=@{ReactivateR}>Forgot your Password?
<script src="/static/js/jquery.min.js" type="text/javascript"> <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">