Merge branch 'hmac_sha3'

.gitignore

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

Handler/Login.hs

@@ -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)
+            let expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted)
-            if
+            if encodeUtf8 hexResponse == expected
-              fromHex' (T.unpack 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)

Makefile

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

bower.json

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

eidolon.cabal

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

src/Activate.purs

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

src/Common.js

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

src/Common.purs

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

src/Login.purs

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

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

templates/login.hamlet

@@ -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/jsSHA.js" type="text/javascript">-->
-  <script src="/static/js/login.js" type="text/javascript">
+  <script src="/static/js/purs_login.js" type="text/javascript">

templates/profileSettings.hamlet

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