diff --git a/.gitignore b/.gitignore index 73ae73b..125200f 100755 --- a/.gitignore +++ b/.gitignore @@ -14,3 +14,9 @@ cabal.sandbox.config *.swp static/data* .stack-work* +/bower_components/ +/node_modules/ +/.pulp-cache/ +/output/ +/.psc* +/.psa* diff --git a/Handler/Login.hs b/Handler/Login.hs index b570c78..3ebdafe 100755 --- a/Handler/Login.hs +++ b/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) - 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) diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..7dc92e4 --- /dev/null +++ b/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 diff --git a/bower.json b/bower.json new file mode 100644 index 0000000..0f71c9f --- /dev/null +++ b/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" + } +} diff --git a/eidolon.cabal b/eidolon.cabal index 4f84801..135f775 100755 --- a/eidolon.cabal +++ b/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 diff --git a/src/Activate.purs b/src/Activate.purs new file mode 100644 index 0000000..e55f700 --- /dev/null +++ b/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" diff --git a/src/Common.js b/src/Common.js new file mode 100644 index 0000000..faedf0b --- /dev/null +++ b/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); +} diff --git a/src/Common.purs b/src/Common.purs new file mode 100644 index 0000000..bac1aed --- /dev/null +++ b/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 :: * diff --git a/src/Login.purs b/src/Login.purs new file mode 100644 index 0000000..f035088 --- /dev/null +++ b/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 diff --git a/templates/activate.hamlet b/templates/activate.hamlet index f9be960..8696497 100755 --- a/templates/activate.hamlet +++ b/templates/activate.hamlet @@ -5,14 +5,14 @@ $newline always