change hashing procedure for avatars and prepare hashing of passwords

TODO.md

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

mateamt.cabal

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

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

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

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