added avatar functionality

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

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

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]

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

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

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

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
+    }

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"

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

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