first toying around with avatars.

This commit is contained in:
nek0 2015-04-16 02:12:03 +02:00
parent 85b743a535
commit edc307a01f
18 changed files with 235 additions and 13 deletions

View File

@ -35,6 +35,7 @@ import Handler.Payout
import Handler.Summary
import Handler.Modify
import Handler.CashCheck
import Handler.Avatar
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the

115
Handler/Avatar.hs Normal file
View File

@ -0,0 +1,115 @@
module Handler.Avatar where
import Import
import Data.Conduit
import Data.Conduit.Binary
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Graphics.ImageMagick.MagickWand
getAvatarR :: Handler Html
getAvatarR = do
avatars <- runDB $ selectList [] [Asc AvatarIdent]
defaultLayout $ do
$(widgetFile "avatars")
getNewAvatarR :: Handler Html
getNewAvatarR = do
(newAvatarWidget, enctype) <- generateFormPost $ avatarNewForm
defaultLayout $ do
$(widgetFile "newAvatar")
postNewAvatarR :: Handler Html
postNewAvatarR = do
((res, _), _) <- runFormPost $ avatarNewForm
case res of
FormSuccess na -> do
raw <- runResourceT $ fileSource (avatarNewFile na) $$ sinkLbs
thumb <- generateThumb $ B.concat $ L.toChunks raw
runDB $ insert_ $ Avatar (avatarNewIdent na) thumb
setMessageI MsgAvatarUploadSuccessfull
redirect $ HomeR
_ -> do
setMessageI MsgErrorOccured
redirect $ NewAvatarR
avatarNewForm :: Form AvatarNew
avatarNewForm = renderDivs $ AvatarNew
<$> areq textField (fieldSettingsLabel MsgAvatarIdent) Nothing
<*> areq fileField (fieldSettingsLabel MsgAvatarFile) Nothing
data AvatarNew = AvatarNew
{ avatarNewIdent :: Text
, avatarNewFile :: FileInfo
}
getModifyAvatarR :: AvatarId -> Handler Html
getModifyAvatarR aId = do
ma <- runDB $ get aId
case ma of
Just avatar -> do
(avatarModifyWidget, enctype) <- generateFormPost $ avatarModForm avatar
defaultLayout $ do
$(widgetFile "modifyAvatar")
Nothing -> do
setMessageI MsgAvatarUnknown
redirect $ AvatarR
postModifyAvatarR :: AvatarId -> Handler Html
postModifyAvatarR aId = do
ma <- runDB $ get aId
case ma of
Just avatar -> do
((res, _), _) <- runFormPost $ avatarModForm avatar
case res of
FormSuccess md -> do
updateAvatar aId md
setMessageI MsgAvatarUpdateSuccessfull
redirect $ AvatarR
_ -> do
setMessageI MsgErrorOccured
redirect $ ModifyAvatarR aId
Nothing -> do
setMessageI MsgAvatarUnknown
redirect $ HomeR
avatarModForm :: Avatar -> Form AvatarMod
avatarModForm a = renderDivs $ AvatarMod
<$> areq textField (fieldSettingsLabel MsgAvatarIdent) (Just $ avatarIdent a)
<*> aopt fileField (fieldSettingsLabel MsgAvatarFileChange) Nothing
data AvatarMod = AvatarMod
{ avatarModIdent :: Text
, avatarModFile :: Maybe FileInfo
}
updateAvatar :: AvatarId -> AvatarMod -> Handler ()
updateAvatar aId (AvatarMod ident Nothing) = do
runDB $ update aId [AvatarIdent =. ident]
updateAvatar aId (AvatarMod ident (Just fi)) = do
raw <- runResourceT $ fileSource fi $$ sinkLbs
thumb <- generateThumb $ B.concat $ L.toChunks raw
runDB $ update aId
[ AvatarIdent =. ident
, AvatarData =. thumb
]
generateThumb :: ByteString -> Handler ByteString
generateThumb raw = do
thumb <- liftIO $ withMagickWandGenesis $ do
(_, w) <- magickWand
readImageBlob w raw
w1 <- getImageWidth w
h1 <- getImageHeight w
h2 <- return 140
w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2) :: Double)
resizeImage w w2 h2 lanczosFilter 1
setImageCompressionQuality w 95
setImageFormat w "png"
getImageBlob w
return thumb
getGetAvatarR :: AvatarId -> Handler TypedContent
getGetAvatarR aId = do
avatar <- runDB $ get404 aId
return $ TypedContent typePng $ toContent $ avatarData avatar

View File

@ -44,6 +44,11 @@ modifyForm bev = renderDivs $ Beverage
<*> areq currencyField (fieldSettingsLabel MsgPrice) (Just $ beveragePrice bev)
<*> areq amountField (fieldSettingsLabel MsgCurrentStock) (Just $ beverageAmount bev)
<*> areq amountField (fieldSettingsLabel MsgAnnouncedStock) (Just $ beverageAlertAmount bev)
<*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ beverageAvatar bev)
where
avatars = do
ents <- runDB $ selectList [] [Asc AvatarIdent]
optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents
getDeleteBeverageR :: BeverageId -> Handler Html
getDeleteBeverageR bId = do

View File

@ -33,6 +33,11 @@ newUserForm secs = renderDivs $ User
<*> pure 0
<*> pure secs
<*> aopt emailField (fieldSettingsLabel MsgEmailNotify) Nothing
<*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) Nothing
where
avatars = do
ents <- runDB $ selectList [] [Asc AvatarIdent]
optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents
data UserConf = UserConf
{ userConfEmail :: Maybe Text

View File

@ -72,3 +72,8 @@ newArticleForm = renderDivs $ Beverage
<*> areq currencyField (fieldSettingsLabel MsgPrice) (Just 100)
<*> areq amountField (fieldSettingsLabel MsgAmount) (Just 0)
<*> areq amountField (fieldSettingsLabel MsgAmountWarning) (Just 0)
<*> aopt (selectField albums) (fieldSettingsLabel MsgSelectAvatar) Nothing
where
albums = do
ents <- runDB $ selectList [] [Asc AvatarIdent]
optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents

View File

@ -26,8 +26,15 @@ getSummaryJsonR = do
]
) bevs
instance ToJSON Beverage where
toJSON (Beverage ident price amount alertAmount) =
data BevStore = BevStore
{ bevStoreIdent :: Text
, bevStorePrice :: Int
, bevStoreAmount :: Int
, bevStoreAlertAmount :: Int
}
instance ToJSON BevStore where
toJSON (BevStore ident price amount alertAmount) =
object
[ "name" .= ident
, "price" .= price
@ -35,8 +42,8 @@ instance ToJSON Beverage where
, "alertAt" .= alertAmount
]
instance FromJSON Beverage where
parseJSON (Object o) = Beverage
instance FromJSON BevStore where
parseJSON (Object o) = BevStore
<$> o .: "name"
<*> o .: "price"
<*> o .: "amount"
@ -49,7 +56,12 @@ getInventoryJsonR = do
bevs <- runDB $ selectList [] [Asc BeverageIdent]
return $
repJson $ array $
map (\(Entity _ bev) -> toJSON bev) bevs
map (\(Entity _ bev) -> toJSON $ BevStore
(beverageIdent bev)
(beveragePrice bev)
(beverageAmount bev)
(beverageAlertAmount bev)
) bevs
getUploadInventoryJsonR :: Handler Html
getUploadInventoryJsonR = do
@ -65,7 +77,7 @@ postUploadInventoryJsonR = do
case fileContentType file == "application/json" of
True -> do
source <- runResourceT $ fileSource file $$ sinkLbs
bevs <- return $ fromMaybe [] $ (decode source :: Maybe [Beverage])
bevs <- return $ fromMaybe [] $ (decode source :: Maybe [BevStore])
_ <- return $ map insOrUpd bevs
setMessageI MsgRestoreSuccess
redirect $ HomeR
@ -80,15 +92,20 @@ uploadJsonForm :: Form FileInfo
uploadJsonForm = renderDivs
$ areq fileField (fieldSettingsLabel MsgSelectFile) Nothing
insOrUpd :: Beverage -> Handler ()
insOrUpd :: BevStore -> Handler ()
insOrUpd bev = do
meb <- runDB $ getBy $ UniqueBeverage $ beverageIdent bev
meb <- runDB $ getBy $ UniqueBeverage $ bevStoreIdent bev
case meb of
Just eb -> do
runDB $ update (entityKey eb)
[ BeveragePrice =. beveragePrice bev
, BeverageAmount =. beverageAmount bev
, BeverageAlertAmount =. beverageAlertAmount bev
[ BeveragePrice =. bevStorePrice bev
, BeverageAmount =. bevStoreAmount bev
, BeverageAlertAmount =. bevStoreAlertAmount bev
]
Nothing -> do
runDB $ insert_ bev
runDB $ insert_ $ Beverage
(bevStoreIdent bev)
(bevStorePrice bev)
(bevStoreAmount bev)
(bevStoreAlertAmount bev)
Nothing

View File

@ -3,6 +3,7 @@ User
balance Int
timestamp Int
email Text Maybe
avatar AvatarId Maybe
UniqueUser ident
deriving Typeable Show
Beverage
@ -10,6 +11,7 @@ Beverage
price Int
amount Int
alertAmount Int
avatar AvatarId Maybe
UniqueBeverage ident
deriving Typeable Show
Transaction
@ -25,5 +27,9 @@ CashCheck
balance Int
time UTCTime
deriving Typeable Show
Avatar
ident Text
data ByteString
deriving Typeable Show
-- By default this file is used in Model.hs (which is imported by Foundation.hs)

View File

@ -25,3 +25,7 @@
/cashcheck CashCheckR GET POST
/backup UploadInventoryJsonR GET POST
/backup/inventory.json InventoryJsonR GET
/avatars AvatarR GET
/avatar/#AvatarId GetAvatarR GET
/avatar/#AvatarId/modify ModifyAvatarR GET POST
/newavatar NewAvatarR GET POST

View File

@ -83,3 +83,6 @@ RestoreFromBackup: Nahrát záĺohu
NegativeRecharge: Nelze nabít negativní obnos
Increment: ++
Decrement: --
SelectAvatar: Vyber avatar
NoAvatars: žádné avatary
ModifyAvatar: Modify avatar

View File

@ -83,3 +83,14 @@ RestoreFromBackup: Inventar wiederherstellen
NegativeRecharge: Keine negativen Beträge aufladen
Increment: ++
Decrement: --
SelectAvatar: Avatar auswählen
Avatars: Avatare
NoAvatars: Keine Avatare
ModifyAvatar: Avatar bearbeiten
AvatarUnknown: Unbekannter Avatar
AvatarUpdateSuccessfull: Avatar erfolgreich aktualisiert
AvatarIdent: Avtarname
AvatarFileChange: Datei auswählen um Avatar zu ändern
AvatarFile: Datei für den Avatar
NewAvatar: Neuer Avatar
AvatarUploadSuccessfull: Avatar erfolgreich hochgeladen

View File

@ -83,3 +83,6 @@ RestoreFromBackup: Restore from backup
NegativeRecharge: You can not recharge negative amounts
Increment: ++
Decrement: --
SelectAvatar: Select avatar
NoAvatars: No avatars
ModifyAvatar: Modify avatar

View File

@ -83,3 +83,6 @@ RestoreFromBackup: przywróć z kopii zapasowej
NegativeRecharge: You can not recharge negative amounts
Increment: ++
Decrement: --
SelectAvatar: SelectAvatar
NoAvatars: No avatars
ModifyAvatar: Modify avatar

View File

@ -31,7 +31,13 @@ article#func.article {
overflow: hidden;
}
.article p {
.article a img {
position: relative;
top: -7.75em;
text-align: left;
}
.article a p {
display: inline-block;
vertical-align: middle;
line-height: normal;

18
templates/avatars.hamlet Normal file
View File

@ -0,0 +1,18 @@
$doctype 5
<h3>
Avatars
$if null avatars
<p>
_{MsgNoAvatars}
$else
$forall (Entity aId avatar) <- avatars
<article .article>
<a href=@{ModifyAvatarR aId}>
<p>#{avatarIdent avatar}
<img src=@{GetAvatarR aId}>
<ul>
<li>
<a href=@{NewAvatarR}>_{MsgNewAvatar}

View File

@ -26,3 +26,5 @@
<a href=@{JournalR}>_{MsgJournal}
<span>
<a href=@{SummaryR}>_{MsgSummary}
<span>
<a href=@{AvatarR}>_{MsgAvatars}

View File

@ -0,0 +1,8 @@
$doctype 5
<h3>_{MsgModifyAvatar}
<form method=post enctype=#{enctype}>
^{avatarModifyWidget}
<div>
<input type=submit value=_{MsgSubmit}>

View File

@ -0,0 +1,8 @@
$doctype 5
<h3>_{MsgNewAvatar}
<form method=post enctype=#{enctype}>
^{newAvatarWidget}
<div>
<input type=submit value=_{MsgSubmit}>

View File

@ -30,6 +30,7 @@ library
Handler.Summary
Handler.Modify
Handler.CashCheck
Handler.Avatar
if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT
@ -96,6 +97,7 @@ library
, blaze-builder < 0.4.0.0
, split
, conduit-extra
, imagemagick
executable yammat
if flag(library-only)