2019-09-07 18:05:24 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE Arrows #-}
|
|
|
|
module Model.Avatar where
|
|
|
|
|
|
|
|
import qualified Data.Text as T
|
|
|
|
|
|
|
|
import qualified Data.ByteString as BS
|
|
|
|
|
|
|
|
import Data.Int (Int64)
|
|
|
|
|
|
|
|
import Data.Profunctor.Product (p4)
|
|
|
|
|
|
|
|
import qualified Database.PostgreSQL.Simple as PGS
|
|
|
|
|
|
|
|
import Control.Arrow
|
|
|
|
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
|
|
|
|
import Opaleye as O
|
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Types
|
2022-04-16 10:21:17 +00:00
|
|
|
import Classes (FromDatabase(fromDatabase))
|
2019-09-07 18:05:24 +00:00
|
|
|
|
|
|
|
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))
|
2021-07-14 01:08:58 +00:00
|
|
|
(selectTable avatarTable) -< ()
|
2019-09-07 18:05:24 +00:00
|
|
|
returnA -< ret
|
|
|
|
)
|
|
|
|
:: IO
|
|
|
|
[ ( Int
|
|
|
|
, T.Text
|
|
|
|
, BS.ByteString
|
|
|
|
, BS.ByteString
|
|
|
|
)
|
|
|
|
]
|
2022-04-16 10:21:17 +00:00
|
|
|
mapM (return . fromDatabase) avatars
|
2019-09-07 18:05:24 +00:00
|
|
|
|
|
|
|
avatarSelectById
|
|
|
|
:: Int
|
|
|
|
-> PGS.Connection
|
|
|
|
-> IO [Avatar]
|
|
|
|
avatarSelectById aid conn = do
|
2022-04-15 13:35:53 +00:00
|
|
|
avatars <- runSelect conn (proc () -> do
|
|
|
|
stuff@(aaid, _, _, _) <- selectTable avatarTable -< ()
|
|
|
|
restrict -< aaid .== toFields aid
|
|
|
|
returnA -< stuff
|
|
|
|
)
|
2019-09-07 18:05:24 +00:00
|
|
|
:: IO
|
|
|
|
[ ( Int
|
|
|
|
, T.Text
|
|
|
|
, BS.ByteString
|
|
|
|
, BS.ByteString
|
|
|
|
)
|
|
|
|
]
|
2022-04-16 10:21:17 +00:00
|
|
|
mapM (return . fromDatabase) avatars
|
2019-09-07 18:05:24 +00:00
|
|
|
|
|
|
|
insertAvatar
|
|
|
|
:: AvatarData
|
2022-04-16 10:21:17 +00:00
|
|
|
-> BS.ByteString
|
2019-09-07 18:05:24 +00:00
|
|
|
-> PGS.Connection
|
|
|
|
-> MateHandler Int
|
2022-04-16 10:21:17 +00:00
|
|
|
insertAvatar (AvatarData name dat) hash conn = fmap head $ liftIO $ do
|
2019-09-07 18:05:24 +00:00
|
|
|
runInsert_ conn $ Insert
|
|
|
|
{ iTable = avatarTable
|
|
|
|
, iRows =
|
|
|
|
[
|
2021-07-14 01:08:58 +00:00
|
|
|
( toFields (Nothing :: Maybe Int)
|
|
|
|
, toFields name
|
|
|
|
, toFields hash
|
2022-04-16 10:21:17 +00:00
|
|
|
, toFields (BS.pack dat)
|
2019-09-07 18:05:24 +00:00
|
|
|
)
|
|
|
|
]
|
|
|
|
, iReturning = rReturning (\(aid, _, _, _) -> aid)
|
|
|
|
, iOnConflict = Nothing
|
|
|
|
}
|
|
|
|
|
|
|
|
updateAvatar
|
|
|
|
:: Int
|
|
|
|
-> AvatarData
|
2022-04-16 10:21:17 +00:00
|
|
|
-> BS.ByteString
|
2019-09-07 18:05:24 +00:00
|
|
|
-> PGS.Connection
|
|
|
|
-> MateHandler Int64
|
2022-04-16 10:21:17 +00:00
|
|
|
updateAvatar aid (AvatarData name dat) hash conn = liftIO $ do
|
2019-09-07 18:05:24 +00:00
|
|
|
runUpdate_ conn $ Update
|
|
|
|
{ uTable = avatarTable
|
|
|
|
, uUpdateWith = updateEasy (\(did, _, _, _) ->
|
|
|
|
( did
|
2021-07-14 01:08:58 +00:00
|
|
|
, toFields name
|
|
|
|
, toFields hash
|
2022-04-16 10:21:17 +00:00
|
|
|
, toFields (BS.pack dat)
|
2019-09-07 18:05:24 +00:00
|
|
|
)
|
|
|
|
)
|
2021-07-14 01:08:58 +00:00
|
|
|
, uWhere = \(did, _, _, _) -> did .== toFields aid
|
2019-09-07 18:05:24 +00:00
|
|
|
, uReturning = rCount
|
|
|
|
}
|