Merge branch 'hmac_sha3'

This commit is contained in:
nek0 2016-12-03 16:24:29 +01:00
commit 2f03c48e4e
12 changed files with 387 additions and 14 deletions

6
.gitignore vendored
View file

@ -14,3 +14,9 @@ cabal.sandbox.config
*.swp
static/data*
.stack-work*
/bower_components/
/node_modules/
/.pulp-cache/
/output/
/.psc*
/.psa*

View file

@ -18,12 +18,20 @@ module Handler.Login where
import Import hiding (returnJson)
import qualified Data.Text as T
import Crypto.HMAC
-- old hmac
import Crypto.HMAC as Old
import Crypto.Hash.CryptoAPI (SHA1)
import Data.Text.Encoding (encodeUtf8)
-- new hmac
import Crypto.MAC.HMAC as New
import Crypto.Hash.Algorithms (Keccak_512)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
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
@ -65,9 +73,8 @@ postLoginR = do
queriedUser <- runDB $ getJust (fromJust savedUserId)
let salted = userSalted queriedUser
let hexSalted = toHex salted
let expected = hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted)
if
fromHex' (T.unpack hexResponse) == expected
let expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted)
if encodeUtf8 hexResponse == expected
then do
-- Success!!
runDB $ delete tokenId
@ -111,3 +118,6 @@ hmacSHA1 keyData msgData =
sha1 :: SHA1
sha1 = hmac' key msgData
in encode sha1
hmacKeccak :: B.ByteString -> B.ByteString -> B.ByteString
hmacKeccak key msg = BC.pack $ show $ hmacGetDigest (New.hmac key msg :: HMAC Keccak_512)

25
Makefile Normal file
View file

@ -0,0 +1,25 @@
all: hsbuild pursbuild
clean:
cabal clean
rm -r bower_components
rm -r node_modules
rm ./static/js/purs.js
hsdeps:
cabal install --only-dependencies
hsbuild: hsdeps
cabal build
pursdeps: cryptojs
bower install
cryptojs:
npm install crypto-js
npm install react
npm install react-dom
pursbuild: pursdeps
pulp browserify -m Login -O -t ./static/js/purs_login.js
pulp browserify -m Activate -O -t ./static/js/purs_activate.js

24
bower.json Normal file
View file

@ -0,0 +1,24 @@
{
"name": "eidolon",
"ignore": [
"**/.*",
"node_modules",
"bower_components",
"output"
],
"dependencies": {
"purescript-prelude": "^2.1.0",
"purescript-console": "^2.0.0",
"purescript-functions": "^2.0.0",
"purescript-jquery": "^3.0.0",
"purescript-affjax": "^3.0.1",
"purescript-form-urlencoded": "^2.0.0",
"purescript-argonaut": "^2.0.0",
"purescript-react": "^2.0.0",
"purescript-react-dom": "^2.0.0",
"purescript-dom": "^3.2.0"
},
"devDependencies": {
"purescript-psci-support": "^2.0.0"
}
}

View file

@ -111,6 +111,7 @@ library
, cereal >= 0.4
, cryptohash-cryptoapi >= 0.1
, crypto-api >= 0.13
, cryptonite
-- , imagemagick
, yesod-markdown >= 0.10
, blaze-markup >= 0.7

75
src/Activate.purs Normal file
View file

@ -0,0 +1,75 @@
module Activate where
import Prelude (Unit, bind, not, pure, show, unit, ($), (&&), (<>), (=<<), (==))
import Control.Monad.Aff (runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.JQuery (JQuery, JQueryEvent, getValue, on, preventDefault, ready, select)
import DOM (DOM)
import Data.Function.Uncurried (runFn2)
import Data.Maybe (Maybe(..), fromJust, isNothing)
import Data.Tuple (Tuple(..))
import Network.HTTP.Affjax (AJAX, post)
import Data.FormURLEncoded as UE
import Partial.Unsafe (unsafePartial)
import Common (Elem(..), fail, fromForeign, fromHex, fromUtf8, getAttr, hmacSha3, progress, welcome)
-- 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 "activating"
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
log $ "token: " <> token
salt <- getAttr "data-salt" activate
log $ "salt: " <> salt
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"
log $ fromJust password1 <> " " <> salt
let salted = runFn2 hmacSha3 (fromUtf8 $ fromJust password1) (fromHex salt)
log salted
progress "Requesting account activation..."
let dat = UE.fromArray [ Tuple "salted" (Just salted) ]
_ <- 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"

37
src/Common.js Normal file
View file

@ -0,0 +1,37 @@
"use strict";
var CryptoJS = require('crypto-js');
exports.hmacSha3 = function(msg, key) {
var hmac = CryptoJS.HmacSHA3(msg, key);
//console.log("bla");
//console.log(hmac.toString());
//console.log(CryptoJS.enc.Utf8.stringify(hmac));
return hmac.toString();
}
exports.setLocation = function(newLoc) {
window.location = newLoc;
return null;
}
exports.getAttr = function(attr) {
return function(ob) {
return function() {
return ob.attr(attr);
};
};
};
exports.toHex = function(str) {
var repr = parseInt(str, 16);
return repr.toString(16);
}
exports.fromHex = function(str) {
return CryptoJS.enc.Hex.parse(str);
}
exports.fromUtf8 = function(str) {
return CryptoJS.enc.Utf8.parse(str);
}

97
src/Common.purs Normal file
View file

@ -0,0 +1,97 @@
module Common where
import Prelude (Unit, bind, pure, ($), (<$>), (=<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.JQuery (JQuery, display, select, setProp, setText)
import Control.Monad.Except (runExcept)
import DOM (DOM)
import Data.Function.Uncurried (Fn2)
import Data.Maybe (Maybe(..))
import Data.Either (Either(..), either)
import Data.Foreign as F
import Data.Argonaut (class DecodeJson, decodeJson, (.?), Json) as A
import Data.Argonaut.Decode
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 _ -> do
let eitherErr = decodeJson j
either (fail elem) (\(Err e) -> fail elem e.err) eitherErr
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 }
data Err = Err
{ err :: String
}
instance decodeJsonErr :: DecodeJson Err where
decodeJson j = do
obj <- decodeJson j
error <- obj .? "error"
pure $ Err { err: error }
fromForeign :: F.Foreign -> Maybe String
fromForeign f = case runExcept (F.readString f) of
Left e -> Nothing
Right s -> Just s
foreign import hmacSha3 :: Fn2 WordArray WordArray String
foreign import setLocation :: forall eff. String -> Eff (dom :: DOM | eff) Unit
foreign import getAttr
:: forall eff
. String
-> JQuery
-> Eff (dom :: DOM | eff) String
foreign import toHex :: String -> String
foreign import fromHex :: String -> WordArray
foreign import fromUtf8 :: String -> WordArray
foreign import data WordArray :: *

98
src/Login.purs Normal file
View file

@ -0,0 +1,98 @@
module Login where
import Prelude (Unit, bind, not, pure, show, unit, ($), (&&), (<$>), (<>), (=<<))
import Control.Monad.Aff (runAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.JQuery (JQuery, JQueryEvent, getValue, hide, on, preventDefault, ready, select, setProp)
import DOM (DOM)
import Data.Function.Uncurried (runFn2)
import Data.Maybe (Maybe(..), fromJust, isNothing)
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import Data.Argonaut as A
import Data.Argonaut.Decode (decodeJson)
import Network.HTTP.Affjax (AJAX, post)
import Data.FormURLEncoded as UE
import Partial.Unsafe (unsafePartial)
import Common (Challenge(..), Elem(..), fail, fromForeign, fromHex, fromUtf8, hmacSha3, progress, welcome)
-- 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.fromArray $ [ Tuple "username" username ]
_ <- runAff
(\e -> fail Login $ show e)
(\y -> resp1Success (fromJust password) y.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 (fromUtf8 pass) (fromHex challenge.salt)
log $ "salted: " <> salted
progress "HMAC 2"
let response = runFn2 hmacSha3 (fromUtf8 salted) (fromUtf8 challenge.token)
log $ "resp: " <> response
progress "sending response"
let data2 = UE.fromArray $ [ Tuple "token" (Just challenge.token), Tuple "response" (Just response) ]
_ <- runAff
(\e -> fail Login $ show e)
(\x -> welcome x.response Login)
$ post "/login" data2
pure unit

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

@ -10,11 +10,11 @@ $newline always
<label for="password">Password:
<input .form-control #password type="password" required>
<div .form-group .optional>
<button .btn .btn-default #login type="submit">Login
<button .btn .btn-default type="submit" #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">

View file

@ -1,5 +1,5 @@
$newline always
<div .item>
<div .medium>
<form method="post" enctype=#{enctype}>
<h3>Profile settings
^{profileSettingsWidget}