75 lines
1.6 KiB
Haskell
75 lines
1.6 KiB
Haskell
|
{-# 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
|