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
- [ ] Hash Passwords
- [ ] Deactivation of idle users with reactivation procedure
- [ ] Mangement of security mechanism(s)
- [ ] Manage user name

View file

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

View file

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

View file

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

View file

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