85 lines
1.9 KiB
Haskell
85 lines
1.9 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Control.Avatar where
|
|
|
|
import Control.Monad (void)
|
|
|
|
import Control.Monad.Reader (asks)
|
|
|
|
import Control.Monad.Trans (liftIO)
|
|
|
|
import Crypto.Hash
|
|
|
|
import qualified Data.ByteString as BS
|
|
import Data.ByteString.Builder (byteString)
|
|
import Data.ByteString.Base64
|
|
|
|
import Data.String (fromString)
|
|
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
|
|
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 <- asks rsConnection
|
|
as <- liftIO $ avatarSelectById aid conn
|
|
if null as
|
|
then
|
|
return ((\_ response -> response $ responseStream status404 [] $
|
|
\write flush -> do
|
|
write "No avatar found."
|
|
flush
|
|
) :: Application)
|
|
else
|
|
return ((\_ response -> response $ responseStream status200 [(hETag, encodeUtf8 (avatarHash (head as)))] $
|
|
\write flush -> do
|
|
write $ byteString $ BS.pack $ avatarData $ head as
|
|
flush
|
|
) :: Application)
|
|
|
|
avatarInsert
|
|
:: Maybe (Int, AuthMethod)
|
|
-> AvatarData
|
|
-> MateHandler Int
|
|
avatarInsert (Just _) ad = do
|
|
conn <- asks rsConnection
|
|
insertAvatar ad (md5 $ BS.pack $ avatarDataData ad) conn
|
|
avatarInsert Nothing _ =
|
|
throwError $ err401
|
|
{ errBody = "No Authentication present."
|
|
}
|
|
|
|
avatarUpdate
|
|
:: Maybe (Int, AuthMethod)
|
|
-> Int
|
|
-> AvatarData
|
|
-> MateHandler NoContent
|
|
avatarUpdate (Just _) aid ad = do
|
|
conn <- asks rsConnection
|
|
void $ updateAvatar aid ad (md5 $ BS.pack $ avatarDataData ad) conn
|
|
return NoContent
|
|
avatarUpdate Nothing _ _ =
|
|
throwError $ err401
|
|
{ errBody = "No Authentication present."
|
|
}
|
|
|
|
avatarList
|
|
:: MateHandler [Avatar]
|
|
avatarList = do
|
|
conn <- asks rsConnection
|
|
liftIO $ avatarSelect conn
|
|
|
|
md5 :: BS.ByteString -> BS.ByteString
|
|
md5 bs = encode $ fromString (show ( hash bs :: Digest MD5))
|