From f9a3490da583dcfc37a341b4b49c22c08b7e6875 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 16 Apr 2022 12:21:17 +0200 Subject: [PATCH] change hashing procedure for avatars and prepare hashing of passwords --- TODO.md | 1 + mateamt.cabal | 2 +- src/Control/Avatar.hs | 17 ++++++++++++----- src/Model/Avatar.hs | 29 +++++++++-------------------- src/Types/Avatar.hs | 26 +++++++++++++++++++++++--- 5 files changed, 46 insertions(+), 29 deletions(-) diff --git a/TODO.md b/TODO.md index f59a6dd..b426369 100644 --- a/TODO.md +++ b/TODO.md @@ -17,6 +17,7 @@ ### Required +- [ ] Hash Passwords - [ ] Deactivation of idle users with reactivation procedure - [ ] Mangement of security mechanism(s) - [ ] Manage user name diff --git a/mateamt.cabal b/mateamt.cabal index 7371470..cf49701 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -99,7 +99,7 @@ library , http-types , http-api-data , stm - , pureMD5 + , cryptonite , extra , haskell-gettext , mime-mail diff --git a/src/Control/Avatar.hs b/src/Control/Avatar.hs index 9d6430c..f8aa2a4 100644 --- a/src/Control/Avatar.hs +++ b/src/Control/Avatar.hs @@ -7,10 +7,14 @@ import Control.Monad.Reader (asks) import Control.Monad.Trans (liftIO) -import Data.Text.Encoding (encodeUtf8) +import Crypto.Hash + +import qualified Data.ByteString as BS import Data.ByteString.Builder (byteString) +import Data.String (fromString) + import Servant import Network.Wai @@ -36,9 +40,9 @@ avatarGet aid = do flush ) :: Application) else - return ((\_ response -> response $ responseStream status200 [(hETag, encodeUtf8 (avatarHash (head as)))] $ + return ((\_ response -> response $ responseStream status200 [(hETag, BS.pack (avatarHash (head as)))] $ \write flush -> do - write $ byteString $ encodeUtf8 $ avatarData $ head as + write $ byteString $ BS.pack $ avatarData $ head as flush ) :: Application) @@ -48,7 +52,7 @@ avatarInsert -> MateHandler Int avatarInsert (Just _) ad = do conn <- asks rsConnection - insertAvatar ad conn + insertAvatar ad (md5 $ BS.pack $ avatarDataData ad) conn avatarInsert Nothing _ = throwError $ err401 { errBody = "No Authentication present." @@ -61,7 +65,7 @@ avatarUpdate -> MateHandler () avatarUpdate (Just _) aid ad = do conn <- asks rsConnection - void $ updateAvatar aid ad conn + void $ updateAvatar aid ad (md5 $ BS.pack $ avatarDataData ad) conn avatarUpdate Nothing _ _ = throwError $ err401 { errBody = "No Authentication present." @@ -72,3 +76,6 @@ avatarList avatarList = do conn <- asks rsConnection liftIO $ avatarSelect conn + +md5 :: BS.ByteString -> BS.ByteString +md5 bs = fromString (show ( hash bs :: Digest MD5)) diff --git a/src/Model/Avatar.hs b/src/Model/Avatar.hs index 59da2a5..47e3ad3 100644 --- a/src/Model/Avatar.hs +++ b/src/Model/Avatar.hs @@ -3,17 +3,13 @@ module Model.Avatar where import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8, decodeUtf8) import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BS (fromChunks) import Data.Int (Int64) import Data.Profunctor.Product (p4) -import qualified Data.Digest.Pure.MD5 as MD5 - import qualified Database.PostgreSQL.Simple as PGS import Control.Arrow @@ -25,6 +21,7 @@ import Opaleye as O -- internal imports import Types +import Classes (FromDatabase(fromDatabase)) initAvatar :: PGS.Query initAvatar = mconcat @@ -73,11 +70,7 @@ avatarSelect conn = liftIO $ do , BS.ByteString ) ] - mapM - (\(daid, dname, dhash, ddata) -> return $ - Avatar daid dname (decodeUtf8 dhash) (decodeUtf8 ddata) - ) - avatars + mapM (return . fromDatabase) avatars avatarSelectById :: Int @@ -96,18 +89,14 @@ avatarSelectById aid conn = do , BS.ByteString ) ] - mapM - (\(daid, dname, dhash, ddata) -> return $ - Avatar daid dname (decodeUtf8 dhash) (decodeUtf8 ddata) - ) - avatars + mapM (return . fromDatabase) avatars insertAvatar :: AvatarData + -> BS.ByteString -> PGS.Connection -> MateHandler Int -insertAvatar (AvatarData name dat) conn = fmap head $ liftIO $ do - let hash = MD5.md5DigestBytes $ MD5.md5 $ BS.fromChunks [encodeUtf8 dat] +insertAvatar (AvatarData name dat) hash conn = fmap head $ liftIO $ do runInsert_ conn $ Insert { iTable = avatarTable , iRows = @@ -115,7 +104,7 @@ insertAvatar (AvatarData name dat) conn = fmap head $ liftIO $ do ( toFields (Nothing :: Maybe Int) , toFields name , toFields hash - , toFields (encodeUtf8 dat) + , toFields (BS.pack dat) ) ] , iReturning = rReturning (\(aid, _, _, _) -> aid) @@ -125,17 +114,17 @@ insertAvatar (AvatarData name dat) conn = fmap head $ liftIO $ do updateAvatar :: Int -> AvatarData + -> BS.ByteString -> PGS.Connection -> MateHandler Int64 -updateAvatar aid (AvatarData name dat) conn = liftIO $ do - let hash = MD5.md5DigestBytes $ MD5.md5 $ BS.fromChunks [encodeUtf8 dat] +updateAvatar aid (AvatarData name dat) hash conn = liftIO $ do runUpdate_ conn $ Update { uTable = avatarTable , uUpdateWith = updateEasy (\(did, _, _, _) -> ( did , toFields name , toFields hash - , toFields (encodeUtf8 dat) + , toFields (BS.pack dat) ) ) , uWhere = \(did, _, _, _) -> did .== toFields aid diff --git a/src/Types/Avatar.hs b/src/Types/Avatar.hs index e662df0..bd11e31 100644 --- a/src/Types/Avatar.hs +++ b/src/Types/Avatar.hs @@ -1,17 +1,25 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} module Types.Avatar where +import Data.ByteString + import qualified Data.Text as T +import Data.Word (Word8) + import Data.Aeson import GHC.Generics +-- internal imports +import Classes + data Avatar = Avatar { avatarId :: Int , avatarName :: T.Text - , avatarHash :: T.Text - , avatarData :: T.Text + , avatarHash :: [Word8] + , avatarData :: [Word8] } deriving (Show, Generic) @@ -20,10 +28,16 @@ instance ToJSON Avatar where instance FromJSON Avatar +instance FromDatabase Avatar where + type OutTuple Avatar = (Int, T.Text, ByteString, ByteString) + + fromDatabase (id_, name, hash, data_) = + Avatar id_ name (unpack hash) (unpack data_) + data AvatarData = AvatarData { avatarDataName :: T.Text - , avatarDataData :: T.Text + , avatarDataData :: [Word8] } deriving (Show, Generic) @@ -31,3 +45,9 @@ instance ToJSON AvatarData where toEncoding = genericToEncoding defaultOptions instance FromJSON AvatarData + +instance FromDatabase AvatarData where + type OutTuple AvatarData = (T.Text, ByteString) + + fromDatabase (name, data_) = + AvatarData name (unpack data_)