playing around with hashes and randomness

mateamt.cabal

@@ -83,7 +83,7 @@ library
     , bytestring >=0.10.12.0
     , base16-bytestring
     , base64-bytestring
-    , random-bytestring
+    , random
     , servant
     , servant-server
     , servant-rawm >= 0.3.0.0

src/Control/Auth.hs

@@ -10,10 +10,18 @@ import Control.Monad.IO.Class (liftIO)
 
 import Control.Concurrent.STM (readTVarIO)
 
+import Crypto.KDF.Argon2
+import Crypto.Error
+
+import Data.String (fromString)
+
+import Data.Text.Encoding
+
 -- internal imports
 
 import Types
 import Model
+import Util
 
 authGet
   :: TicketRequest
@@ -61,10 +69,18 @@ authManageNewAuth
   -> AuthSubmit
   -> MateHandler Int
 authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) =
-  if method `elem` [PrimaryPass, ChallengeResponse]
+  if method == PrimaryPass
   then do
-    conn <- asks rsConnection
+    salt <- liftIO randomString
-    putUserAuthInfo uid asmethod ascomment aspayload conn
+    let mhashstring = decodeUtf8 <$> hash defaultOptions (encodeUtf8 aspayload) salt 64
+    case mhashstring of
+      CryptoPassed hashstring -> do
+        conn <- asks rsConnection
+        putUserAuthInfo uid asmethod ascomment hashstring conn
+      CryptoFailed err -> do
+        throwError $ err500
+          { errBody = "Crypto Error: " <> fromString (show err)
+          }
   else
     throwError $ err401
       { errBody = "Unauthorized access"

src/Model/Auth.hs

@@ -29,7 +29,6 @@ import qualified Data.Set as S
 import Data.Time.Clock
 
 import Data.ByteString as B (ByteString)
-import Data.ByteString.Random
 import qualified Data.ByteString.Base64 as B64
 
 import Opaleye hiding (null)

src/Types/Auth.hs

@@ -12,7 +12,6 @@ import qualified Data.Set as S
 import Data.Time.Clock (UTCTime)
 
 import Data.ByteString (ByteString)
-import qualified Data.ByteString.Base64 as B64
 
 import qualified Data.Text as T
 import Data.Text.Encoding
@@ -55,10 +54,10 @@ instance FromJSON AuthInfo
 
 instance FromDatabase AuthInfo where
 
-  type OutTuple AuthInfo = (Maybe T.Text, T.Text)
+  type OutTuple AuthInfo = (Maybe ByteString, ByteString)
 
   fromDatabase (mChallenge, ticket) =
-    AuthInfo mChallenge (AuthTicket ticket)
+    AuthInfo (decodeUtf8 <$> mChallenge) (AuthTicket $ decodeUtf8 ticket)
 
 
 data AuthMethod
@@ -152,10 +151,10 @@ data Token = Token
 
 instance FromDatabase Token where
 
-  type OutTuple Token = (T.Text, Int, UTCTime, Int)
+  type OutTuple Token = (ByteString, Int, UTCTime, Int)
 
   fromDatabase (string, usr, expiry, method) =
-    Token string usr expiry (toEnum method)
+    Token (decodeUtf8 string) usr expiry (toEnum method)
 
 
 type TicketStore = TVar (S.Set Ticket)
@@ -194,7 +193,7 @@ instance FromDatabase AuthData where
   type OutTuple AuthData = (Int, Int, Int, T.Text, ByteString)
 
   fromDatabase (id_, usr, method, comm, payload) =
-    AuthData id_ usr (toEnum method) comm (decodeUtf8 $ B64.encode payload)
+    AuthData id_ usr (toEnum method) comm (decodeUtf8 payload)
 
 
 data AuthOverview = AuthOverview

src/Util.hs

@@ -7,6 +7,7 @@ import Servant
 
 import Opaleye
 
+import qualified Data.ByteString as BS
 import Data.ByteString.Lazy (fromStrict)
 
 import Data.Maybe (fromMaybe, fromJust)
@@ -29,6 +30,8 @@ import Network.Mail.Mime
 
 import System.Directory (doesFileExist)
 
+import System.Random.Stateful
+
 -- internal imports
 
 import Model
@@ -152,3 +155,6 @@ sendNotification mail = do
     else
       print ("Warning: sending notification failed: Sendmail not present!"
         :: String)
+
+randomString :: IO BS.ByteString
+randomString = uniformByteStringM 32 =<< newIOGenM (mkStdGen 23)