change hashing procedure for avatars and prepare hashing of passwords

This commit is contained in:
nek0 2022-04-16 12:21:17 +02:00
parent 600fb00c63
commit f9a3490da5
5 changed files with 46 additions and 29 deletions

View file

@ -17,6 +17,7 @@
### Required ### Required
- [ ] Hash Passwords
- [ ] Deactivation of idle users with reactivation procedure - [ ] Deactivation of idle users with reactivation procedure
- [ ] Mangement of security mechanism(s) - [ ] Mangement of security mechanism(s)
- [ ] Manage user name - [ ] Manage user name

View file

@ -99,7 +99,7 @@ library
, http-types , http-types
, http-api-data , http-api-data
, stm , stm
, pureMD5 , cryptonite
, extra , extra
, haskell-gettext , haskell-gettext
, mime-mail , mime-mail

View file

@ -7,10 +7,14 @@ import Control.Monad.Reader (asks)
import Control.Monad.Trans (liftIO) 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.ByteString.Builder (byteString)
import Data.String (fromString)
import Servant import Servant
import Network.Wai import Network.Wai
@ -36,9 +40,9 @@ avatarGet aid = do
flush flush
) :: Application) ) :: Application)
else 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 flush -> do
write $ byteString $ encodeUtf8 $ avatarData $ head as write $ byteString $ BS.pack $ avatarData $ head as
flush flush
) :: Application) ) :: Application)
@ -48,7 +52,7 @@ avatarInsert
-> MateHandler Int -> MateHandler Int
avatarInsert (Just _) ad = do avatarInsert (Just _) ad = do
conn <- asks rsConnection conn <- asks rsConnection
insertAvatar ad conn insertAvatar ad (md5 $ BS.pack $ avatarDataData ad) conn
avatarInsert Nothing _ = avatarInsert Nothing _ =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."
@ -61,7 +65,7 @@ avatarUpdate
-> MateHandler () -> MateHandler ()
avatarUpdate (Just _) aid ad = do avatarUpdate (Just _) aid ad = do
conn <- asks rsConnection conn <- asks rsConnection
void $ updateAvatar aid ad conn void $ updateAvatar aid ad (md5 $ BS.pack $ avatarDataData ad) conn
avatarUpdate Nothing _ _ = avatarUpdate Nothing _ _ =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."
@ -72,3 +76,6 @@ avatarList
avatarList = do avatarList = do
conn <- asks rsConnection conn <- asks rsConnection
liftIO $ avatarSelect conn liftIO $ avatarSelect conn
md5 :: BS.ByteString -> BS.ByteString
md5 bs = fromString (show ( hash bs :: Digest MD5))

View file

@ -3,17 +3,13 @@
module Model.Avatar where module Model.Avatar where
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BS (fromChunks)
import Data.Int (Int64) import Data.Int (Int64)
import Data.Profunctor.Product (p4) import Data.Profunctor.Product (p4)
import qualified Data.Digest.Pure.MD5 as MD5
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
import Control.Arrow import Control.Arrow
@ -25,6 +21,7 @@ import Opaleye as O
-- internal imports -- internal imports
import Types import Types
import Classes (FromDatabase(fromDatabase))
initAvatar :: PGS.Query initAvatar :: PGS.Query
initAvatar = mconcat initAvatar = mconcat
@ -73,11 +70,7 @@ avatarSelect conn = liftIO $ do
, BS.ByteString , BS.ByteString
) )
] ]
mapM mapM (return . fromDatabase) avatars
(\(daid, dname, dhash, ddata) -> return $
Avatar daid dname (decodeUtf8 dhash) (decodeUtf8 ddata)
)
avatars
avatarSelectById avatarSelectById
:: Int :: Int
@ -96,18 +89,14 @@ avatarSelectById aid conn = do
, BS.ByteString , BS.ByteString
) )
] ]
mapM mapM (return . fromDatabase) avatars
(\(daid, dname, dhash, ddata) -> return $
Avatar daid dname (decodeUtf8 dhash) (decodeUtf8 ddata)
)
avatars
insertAvatar insertAvatar
:: AvatarData :: AvatarData
-> BS.ByteString
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> MateHandler Int
insertAvatar (AvatarData name dat) conn = fmap head $ liftIO $ do insertAvatar (AvatarData name dat) hash conn = fmap head $ liftIO $ do
let hash = MD5.md5DigestBytes $ MD5.md5 $ BS.fromChunks [encodeUtf8 dat]
runInsert_ conn $ Insert runInsert_ conn $ Insert
{ iTable = avatarTable { iTable = avatarTable
, iRows = , iRows =
@ -115,7 +104,7 @@ insertAvatar (AvatarData name dat) conn = fmap head $ liftIO $ do
( toFields (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, toFields name , toFields name
, toFields hash , toFields hash
, toFields (encodeUtf8 dat) , toFields (BS.pack dat)
) )
] ]
, iReturning = rReturning (\(aid, _, _, _) -> aid) , iReturning = rReturning (\(aid, _, _, _) -> aid)
@ -125,17 +114,17 @@ insertAvatar (AvatarData name dat) conn = fmap head $ liftIO $ do
updateAvatar updateAvatar
:: Int :: Int
-> AvatarData -> AvatarData
-> BS.ByteString
-> PGS.Connection -> PGS.Connection
-> MateHandler Int64 -> MateHandler Int64
updateAvatar aid (AvatarData name dat) conn = liftIO $ do updateAvatar aid (AvatarData name dat) hash conn = liftIO $ do
let hash = MD5.md5DigestBytes $ MD5.md5 $ BS.fromChunks [encodeUtf8 dat]
runUpdate_ conn $ Update runUpdate_ conn $ Update
{ uTable = avatarTable { uTable = avatarTable
, uUpdateWith = updateEasy (\(did, _, _, _) -> , uUpdateWith = updateEasy (\(did, _, _, _) ->
( did ( did
, toFields name , toFields name
, toFields hash , toFields hash
, toFields (encodeUtf8 dat) , toFields (BS.pack dat)
) )
) )
, uWhere = \(did, _, _, _) -> did .== toFields aid , uWhere = \(did, _, _, _) -> did .== toFields aid

View file

@ -1,17 +1,25 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module Types.Avatar where module Types.Avatar where
import Data.ByteString
import qualified Data.Text as T import qualified Data.Text as T
import Data.Word (Word8)
import Data.Aeson import Data.Aeson
import GHC.Generics import GHC.Generics
-- internal imports
import Classes
data Avatar = Avatar data Avatar = Avatar
{ avatarId :: Int { avatarId :: Int
, avatarName :: T.Text , avatarName :: T.Text
, avatarHash :: T.Text , avatarHash :: [Word8]
, avatarData :: T.Text , avatarData :: [Word8]
} }
deriving (Show, Generic) deriving (Show, Generic)
@ -20,10 +28,16 @@ instance ToJSON Avatar where
instance FromJSON Avatar 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 data AvatarData = AvatarData
{ avatarDataName :: T.Text { avatarDataName :: T.Text
, avatarDataData :: T.Text , avatarDataData :: [Word8]
} }
deriving (Show, Generic) deriving (Show, Generic)
@ -31,3 +45,9 @@ instance ToJSON AvatarData where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AvatarData instance FromJSON AvatarData
instance FromDatabase AvatarData where
type OutTuple AvatarData = (T.Text, ByteString)
fromDatabase (name, data_) =
AvatarData name (unpack data_)