mateamt/src/Control/Avatar.hs

75 lines
1.6 KiB
Haskell
Raw Normal View History

2019-09-07 18:05:24 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Control.Avatar where
import Control.Monad (void)
2019-10-14 20:50:42 +00:00
import Control.Monad.Reader (asks)
2019-09-07 18:05:24 +00:00
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
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
2019-09-07 18:05:24 +00:00
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
2019-09-15 12:59:22 +00:00
:: Maybe (Int, AuthMethod)
2019-09-07 18:05:24 +00:00
-> AvatarData
-> MateHandler Int
avatarInsert (Just _) ad = do
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
2019-09-07 18:05:24 +00:00
insertAvatar ad conn
avatarInsert Nothing _ =
2019-09-11 11:54:18 +00:00
throwError $ err401
2019-09-07 18:05:24 +00:00
{ errBody = "No Authentication present."
}
avatarUpdate
2019-09-15 12:59:22 +00:00
:: Maybe (Int, AuthMethod)
2019-09-07 18:05:24 +00:00
-> Int
-> AvatarData
-> MateHandler ()
avatarUpdate (Just _) aid ad = do
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
2019-09-07 18:05:24 +00:00
void $ updateAvatar aid ad conn
2019-10-14 20:50:42 +00:00
avatarUpdate Nothing _ _ =
2019-09-11 11:54:18 +00:00
throwError $ err401
2019-09-07 18:05:24 +00:00
{ errBody = "No Authentication present."
}
avatarList
:: MateHandler [Avatar]
avatarList = do
2019-10-14 20:50:42 +00:00
conn <- asks rsConnection
2019-09-07 18:05:24 +00:00
liftIO $ avatarSelect conn