added avatar functionality

This commit is contained in:
nek0 2019-09-07 20:05:24 +02:00
parent 85b2cc0ceb
commit 272bcb6ab6
10 changed files with 274 additions and 2 deletions

View file

@ -35,6 +35,7 @@ main = do
conn <- connectPostgreSQL
"host='localhost' port=5432 dbname='mateamt' user='mateamt' password='mateamt'"
store <- newTVarIO empty
void $ execute_ conn initAvatar
void $ execute_ conn initUser
void $ execute_ conn initProduct
void $ execute_ conn initToken
@ -75,7 +76,12 @@ app initState =
buy :<|>
journalShow
journalShow :<|>
avatarGet :<|>
avatarInsert :<|>
avatarUpdate :<|>
avatarList
)
userApi :: Proxy MateAPI

View file

@ -49,12 +49,14 @@ library
, Control.User
, Control.Product
, Control.Auth
, Control.Avatar
, Model
, Model.User
, Model.Product
, Model.Auth
, Model.Amount
, Model.Journal
, Model.Avatar
, Types
, Types.Auth
, Types.Product
@ -64,10 +66,12 @@ library
, Types.Purchase
, Types.Amount
, Types.Journal
, Types.Avatar
-- other-extensions:
build-depends: base ^>=4.12.0.0
, servant
, servant-server
, servant-rawm
, opaleye
, aeson
, text
@ -77,6 +81,7 @@ library
, warp
, wai
, wai-logger
, http-types
, http-api-data
, bytestring
, base16-bytestring
@ -84,6 +89,7 @@ library
, containers
, stm
, mtl
, pureMD5
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall

View file

@ -11,6 +11,7 @@
module API where
import Servant.API
import Servant.RawM
-- internal imports
@ -48,3 +49,10 @@ type MateAPI =
:<|> "journal" :> AuthProtect "header-auth" :> QueryParam "limit" Int
:> QueryParam "offset" Int :> Get '[JSON] [JournalEntry]
:<|> "avatar" :> Capture "id" Int :> RawM
:<|> "avatar" :> AuthProtect "header-auth" :> ReqBody '[JSON] AvatarData
:> Post '[JSON] Int
:<|> "avatar" :> AuthProtect "header-auth" :> Capture "id" Int
:> ReqBody '[JSON] AvatarData :> Patch '[JSON] ()
:<|> "avatar" :> "list" :> Get '[JSON] [Avatar]

View file

@ -7,3 +7,4 @@ import Control.Journal as C
import Control.User as C
import Control.Auth as C
import Control.Product as C
import Control.Avatar as C

74
src/Control/Avatar.hs Normal file
View file

@ -0,0 +1,74 @@
{-# LANGUAGE OverloadedStrings #-}
module Control.Avatar where
import Control.Monad (void)
import Control.Monad.Reader (ask)
import Control.Monad.Trans (liftIO)
import Data.Text.Encoding (encodeUtf8)
import Data.ByteString.Builder (byteString)
import Servant
import Network.Wai
import Network.HTTP.Types.Status (status200, status404)
import Network.HTTP.Types.Header (hETag)
-- internal imports
import Types
import Model
avatarGet
:: Int
-> MateHandler Application
avatarGet aid = do
conn <- rsConnection <$> ask
as <- liftIO $ avatarSelectById aid conn
if null as
then
return ((\_ respond -> respond $ responseStream status404 [] $
\write flush -> do
write "No avatar found."
flush
) :: Application)
else
return ((\_ respond -> respond $ responseStream status200 [(hETag, encodeUtf8 (avatarHash (head as)))] $
\write flush -> do
write $ byteString $ encodeUtf8 $ avatarData $ head as
flush
) :: Application)
avatarInsert
:: Maybe Int
-> AvatarData
-> MateHandler Int
avatarInsert (Just _) ad = do
conn <- rsConnection <$> ask
insertAvatar ad conn
avatarInsert Nothing _ =
throwError $ err403
{ errBody = "No Authentication present."
}
avatarUpdate
:: Maybe Int
-> Int
-> AvatarData
-> MateHandler ()
avatarUpdate (Just _) aid ad = do
conn <- rsConnection <$> ask
void $ updateAvatar aid ad conn
avatarUpdate Nothing _ _ = do
throwError $ err403
{ errBody = "No Authentication present."
}
avatarList
:: MateHandler [Avatar]
avatarList = do
conn <- rsConnection <$> ask
liftIO $ avatarSelect conn

View file

@ -7,3 +7,4 @@ import Model.Product as M
import Model.Auth as M
import Model.Amount as M
import Model.Journal as M
import Model.Avatar as M

142
src/Model/Avatar.hs Normal file
View file

@ -0,0 +1,142 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Arrows #-}
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
import Control.Monad.IO.Class (liftIO)
import Opaleye as O
import Opaleye.Constant as C
-- internal imports
import Types
initAvatar :: PGS.Query
initAvatar = mconcat
[ "CREATE TABLE IF NOT EXISTS \"avatar\" ("
, "avatar_id SERIAL PRIMARY KEY,"
, "avatar_name TEXT NOT NULL,"
, "avatar_hash BYTEA NOT NULL,"
, "avatar_data BYTEA NOT NULL"
, ")"
]
avatarTable :: Table
( Maybe (Field SqlInt4)
, Field SqlText
, Field SqlBytea
, Field SqlBytea
)
( Field SqlInt4
, Field SqlText
, Field SqlBytea
, Field SqlBytea
)
avatarTable = table "avatar" (
p4
( tableField "avatar_id"
, tableField "avatar_name"
, tableField "avatar_hash"
, tableField "avatar_data"
)
)
avatarSelect
:: PGS.Connection
-> IO [Avatar]
avatarSelect conn = liftIO $ do
avatars <- runSelect conn (
proc () -> do
ret <- orderBy (desc (\(_, name, _, _) -> name))
(queryTable avatarTable) -< ()
returnA -< ret
)
:: IO
[ ( Int
, T.Text
, BS.ByteString
, BS.ByteString
)
]
mapM
(\(daid, dname, dhash, ddata) -> return $
Avatar daid dname (decodeUtf8 dhash) (decodeUtf8 ddata)
)
avatars
avatarSelectById
:: Int
-> PGS.Connection
-> IO [Avatar]
avatarSelectById aid conn = do
avatars <- runSelect conn (
keepWhen (\(aaid, _, _, _) -> aaid .== C.constant aid)
<<< queryTable avatarTable)
:: IO
[ ( Int
, T.Text
, BS.ByteString
, BS.ByteString
)
]
mapM
(\(daid, dname, dhash, ddata) -> return $
Avatar daid dname (decodeUtf8 dhash) (decodeUtf8 ddata)
)
avatars
insertAvatar
:: AvatarData
-> PGS.Connection
-> MateHandler Int
insertAvatar (AvatarData name dat) conn = fmap head $ liftIO $ do
let hash = MD5.md5DigestBytes $ MD5.md5 $ BS.fromChunks [encodeUtf8 dat]
runInsert_ conn $ Insert
{ iTable = avatarTable
, iRows =
[
( C.constant (Nothing :: Maybe Int)
, C.constant name
, C.constant hash
, C.constant (encodeUtf8 dat)
)
]
, iReturning = rReturning (\(aid, _, _, _) -> aid)
, iOnConflict = Nothing
}
updateAvatar
:: Int
-> AvatarData
-> PGS.Connection
-> MateHandler Int64
updateAvatar aid (AvatarData name dat) conn = liftIO $ do
let hash = MD5.md5DigestBytes $ MD5.md5 $ BS.fromChunks [encodeUtf8 dat]
runUpdate_ conn $ Update
{ uTable = avatarTable
, uUpdateWith = updateEasy (\(did, _, _, _) ->
( did
, C.constant name
, C.constant hash
, C.constant (encodeUtf8 dat)
)
)
, uWhere = (\(did, _, _, _) -> did .== C.constant aid)
, uReturning = rCount
}

View file

@ -35,7 +35,7 @@ initUser = mconcat
, "user_balance INTEGER NOT NULL,"
, "user_timestamp DATE NOT NULL,"
, "user_email TEXT,"
, "user_avatar INTEGER,"
, "user_avatar INTEGER REFERENCES \"avatar\"(\"avatar_id\") ON DELETE CASCADE,"
, "user_salt BYTEA NOT NULL,"
, "user_hash BYTEA,"
, "user_algo INTEGER"

View file

@ -10,3 +10,4 @@ import Types.User as T
import Types.Purchase as T
import Types.Amount as T
import Types.Journal as T
import Types.Avatar as T

33
src/Types/Avatar.hs Normal file
View file

@ -0,0 +1,33 @@
{-# LANGUAGE DeriveGeneric #-}
module Types.Avatar where
import qualified Data.Text as T
import Data.Aeson
import GHC.Generics
data Avatar = Avatar
{ avatarId :: Int
, avatarName :: T.Text
, avatarHash :: T.Text
, avatarData :: T.Text
}
deriving (Show, Generic)
instance ToJSON Avatar where
toEncoding = genericToEncoding defaultOptions
instance FromJSON Avatar
data AvatarData = AvatarData
{ avatarDataName :: T.Text
, avatarDataData :: T.Text
}
deriving (Show, Generic)
instance ToJSON AvatarData where
toEncoding = genericToEncoding defaultOptions
instance FromJSON AvatarData