From 272bcb6ab66c38977a883038db204c3f2dc0477e Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 7 Sep 2019 20:05:24 +0200 Subject: [PATCH] added avatar functionality --- app/Main.hs | 8 ++- mateamt.cabal | 6 ++ src/API.hs | 8 +++ src/Control.hs | 1 + src/Control/Avatar.hs | 74 ++++++++++++++++++++++ src/Model.hs | 1 + src/Model/Avatar.hs | 142 ++++++++++++++++++++++++++++++++++++++++++ src/Model/User.hs | 2 +- src/Types.hs | 1 + src/Types/Avatar.hs | 33 ++++++++++ 10 files changed, 274 insertions(+), 2 deletions(-) create mode 100644 src/Control/Avatar.hs create mode 100644 src/Model/Avatar.hs create mode 100644 src/Types/Avatar.hs diff --git a/app/Main.hs b/app/Main.hs index 3577085..0420850 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/mateamt.cabal b/mateamt.cabal index 1e82de2..5b6f7be 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -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 diff --git a/src/API.hs b/src/API.hs index 54d543b..0bb8038 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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] diff --git a/src/Control.hs b/src/Control.hs index 37325d6..ac7dba6 100644 --- a/src/Control.hs +++ b/src/Control.hs @@ -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 diff --git a/src/Control/Avatar.hs b/src/Control/Avatar.hs new file mode 100644 index 0000000..b443403 --- /dev/null +++ b/src/Control/Avatar.hs @@ -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 diff --git a/src/Model.hs b/src/Model.hs index 7db6fbb..c262989 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -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 diff --git a/src/Model/Avatar.hs b/src/Model/Avatar.hs new file mode 100644 index 0000000..331ba0c --- /dev/null +++ b/src/Model/Avatar.hs @@ -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 + } diff --git a/src/Model/User.hs b/src/Model/User.hs index 315c06f..719adcf 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -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" diff --git a/src/Types.hs b/src/Types.hs index d893910..1c43023 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/Avatar.hs b/src/Types/Avatar.hs new file mode 100644 index 0000000..e662df0 --- /dev/null +++ b/src/Types/Avatar.hs @@ -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