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.Summary
import Handler.Modify import Handler.Modify
import Handler.CashCheck import Handler.CashCheck
import Handler.Avatar
-- This line actually creates our YesodDispatch instance. It is the second half -- 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 -- 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 currencyField (fieldSettingsLabel MsgPrice) (Just $ beveragePrice bev)
<*> areq amountField (fieldSettingsLabel MsgCurrentStock) (Just $ beverageAmount bev) <*> areq amountField (fieldSettingsLabel MsgCurrentStock) (Just $ beverageAmount bev)
<*> areq amountField (fieldSettingsLabel MsgAnnouncedStock) (Just $ beverageAlertAmount 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 :: BeverageId -> Handler Html
getDeleteBeverageR bId = do getDeleteBeverageR bId = do

View file

@ -33,6 +33,11 @@ newUserForm secs = renderDivs $ User
<*> pure 0 <*> pure 0
<*> pure secs <*> pure secs
<*> aopt emailField (fieldSettingsLabel MsgEmailNotify) Nothing <*> 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 data UserConf = UserConf
{ userConfEmail :: Maybe Text { userConfEmail :: Maybe Text

View file

@ -72,3 +72,8 @@ newArticleForm = renderDivs $ Beverage
<*> areq currencyField (fieldSettingsLabel MsgPrice) (Just 100) <*> areq currencyField (fieldSettingsLabel MsgPrice) (Just 100)
<*> areq amountField (fieldSettingsLabel MsgAmount) (Just 0) <*> areq amountField (fieldSettingsLabel MsgAmount) (Just 0)
<*> areq amountField (fieldSettingsLabel MsgAmountWarning) (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 ) bevs
instance ToJSON Beverage where data BevStore = BevStore
toJSON (Beverage ident price amount alertAmount) = { bevStoreIdent :: Text
, bevStorePrice :: Int
, bevStoreAmount :: Int
, bevStoreAlertAmount :: Int
}
instance ToJSON BevStore where
toJSON (BevStore ident price amount alertAmount) =
object object
[ "name" .= ident [ "name" .= ident
, "price" .= price , "price" .= price
@ -35,8 +42,8 @@ instance ToJSON Beverage where
, "alertAt" .= alertAmount , "alertAt" .= alertAmount
] ]
instance FromJSON Beverage where instance FromJSON BevStore where
parseJSON (Object o) = Beverage parseJSON (Object o) = BevStore
<$> o .: "name" <$> o .: "name"
<*> o .: "price" <*> o .: "price"
<*> o .: "amount" <*> o .: "amount"
@ -49,7 +56,12 @@ getInventoryJsonR = do
bevs <- runDB $ selectList [] [Asc BeverageIdent] bevs <- runDB $ selectList [] [Asc BeverageIdent]
return $ return $
repJson $ array $ 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 :: Handler Html
getUploadInventoryJsonR = do getUploadInventoryJsonR = do
@ -65,7 +77,7 @@ postUploadInventoryJsonR = do
case fileContentType file == "application/json" of case fileContentType file == "application/json" of
True -> do True -> do
source <- runResourceT $ fileSource file $$ sinkLbs source <- runResourceT $ fileSource file $$ sinkLbs
bevs <- return $ fromMaybe [] $ (decode source :: Maybe [Beverage]) bevs <- return $ fromMaybe [] $ (decode source :: Maybe [BevStore])
_ <- return $ map insOrUpd bevs _ <- return $ map insOrUpd bevs
setMessageI MsgRestoreSuccess setMessageI MsgRestoreSuccess
redirect $ HomeR redirect $ HomeR
@ -80,15 +92,20 @@ uploadJsonForm :: Form FileInfo
uploadJsonForm = renderDivs uploadJsonForm = renderDivs
$ areq fileField (fieldSettingsLabel MsgSelectFile) Nothing $ areq fileField (fieldSettingsLabel MsgSelectFile) Nothing
insOrUpd :: Beverage -> Handler () insOrUpd :: BevStore -> Handler ()
insOrUpd bev = do insOrUpd bev = do
meb <- runDB $ getBy $ UniqueBeverage $ beverageIdent bev meb <- runDB $ getBy $ UniqueBeverage $ bevStoreIdent bev
case meb of case meb of
Just eb -> do Just eb -> do
runDB $ update (entityKey eb) runDB $ update (entityKey eb)
[ BeveragePrice =. beveragePrice bev [ BeveragePrice =. bevStorePrice bev
, BeverageAmount =. beverageAmount bev , BeverageAmount =. bevStoreAmount bev
, BeverageAlertAmount =. beverageAlertAmount bev , BeverageAlertAmount =. bevStoreAlertAmount bev
] ]
Nothing -> do 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 balance Int
timestamp Int timestamp Int
email Text Maybe email Text Maybe
avatar AvatarId Maybe
UniqueUser ident UniqueUser ident
deriving Typeable Show deriving Typeable Show
Beverage Beverage
@ -10,6 +11,7 @@ Beverage
price Int price Int
amount Int amount Int
alertAmount Int alertAmount Int
avatar AvatarId Maybe
UniqueBeverage ident UniqueBeverage ident
deriving Typeable Show deriving Typeable Show
Transaction Transaction
@ -25,5 +27,9 @@ CashCheck
balance Int balance Int
time UTCTime time UTCTime
deriving Typeable Show 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) -- 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 /cashcheck CashCheckR GET POST
/backup UploadInventoryJsonR GET POST /backup UploadInventoryJsonR GET POST
/backup/inventory.json InventoryJsonR GET /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 NegativeRecharge: Nelze nabít negativní obnos
Increment: ++ Increment: ++
Decrement: -- 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 NegativeRecharge: Keine negativen Beträge aufladen
Increment: ++ Increment: ++
Decrement: -- 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 NegativeRecharge: You can not recharge negative amounts
Increment: ++ Increment: ++
Decrement: -- 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 NegativeRecharge: You can not recharge negative amounts
Increment: ++ Increment: ++
Decrement: -- Decrement: --
SelectAvatar: SelectAvatar
NoAvatars: No avatars
ModifyAvatar: Modify avatar

View file

@ -31,7 +31,13 @@ article#func.article {
overflow: hidden; overflow: hidden;
} }
.article p { .article a img {
position: relative;
top: -7.75em;
text-align: left;
}
.article a p {
display: inline-block; display: inline-block;
vertical-align: middle; vertical-align: middle;
line-height: normal; 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} <a href=@{JournalR}>_{MsgJournal}
<span> <span>
<a href=@{SummaryR}>_{MsgSummary} <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.Summary
Handler.Modify Handler.Modify
Handler.CashCheck Handler.CashCheck
Handler.Avatar
if flag(dev) || flag(library-only) if flag(dev) || flag(library-only)
cpp-options: -DDEVELOPMENT cpp-options: -DDEVELOPMENT
@ -96,6 +97,7 @@ library
, blaze-builder < 0.4.0.0 , blaze-builder < 0.4.0.0
, split , split
, conduit-extra , conduit-extra
, imagemagick
executable yammat executable yammat
if flag(library-only) if flag(library-only)