mateamt/src/Model/Avatar.hs

133 lines
2.7 KiB
Haskell
Raw Normal View History

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
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
)
]
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
)
]
mapM (return . fromDatabase) avatars
2019-09-07 18:05:24 +00:00
insertAvatar
:: AvatarData
-> BS.ByteString
2019-09-07 18:05:24 +00:00
-> PGS.Connection
-> MateHandler Int
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
, toFields (BS.pack dat)
2019-09-07 18:05:24 +00:00
)
]
, iReturning = rReturning (\(aid, _, _, _) -> aid)
, iOnConflict = Nothing
}
updateAvatar
:: Int
-> AvatarData
-> BS.ByteString
2019-09-07 18:05:24 +00:00
-> PGS.Connection
-> MateHandler Int64
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
, 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
}