mateamt/src/Control/Avatar.hs

82 lines
1.8 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 Crypto.Hash
import qualified Data.ByteString as BS
2019-09-07 18:05:24 +00:00
import Data.ByteString.Builder (byteString)
import Data.String (fromString)
2019-09-07 18:05:24 +00:00
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
2022-04-15 18:51:22 +00:00
return ((\_ response -> response $ responseStream status404 [] $
2019-09-07 18:05:24 +00:00
\write flush -> do
write "No avatar found."
flush
) :: Application)
else
return ((\_ response -> response $ responseStream status200 [(hETag, BS.pack (avatarHash (head as)))] $
2019-09-07 18:05:24 +00:00
\write flush -> do
write $ byteString $ BS.pack $ avatarData $ head as
2019-09-07 18:05:24 +00:00
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
insertAvatar ad (md5 $ BS.pack $ avatarDataData ad) conn
2019-09-07 18:05:24 +00:00
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
void $ updateAvatar aid ad (md5 $ BS.pack $ avatarDataData 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
md5 :: BS.ByteString -> BS.ByteString
md5 bs = fromString (show ( hash bs :: Digest MD5))