diff --git a/Application.hs b/Application.hs
index cb95dc5..a1ee869 100644
--- a/Application.hs
+++ b/Application.hs
@@ -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
diff --git a/Handler/Avatar.hs b/Handler/Avatar.hs
new file mode 100644
index 0000000..e8178da
--- /dev/null
+++ b/Handler/Avatar.hs
@@ -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
diff --git a/Handler/Modify.hs b/Handler/Modify.hs
index 4cc4cac..d8fa0eb 100644
--- a/Handler/Modify.hs
+++ b/Handler/Modify.hs
@@ -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
diff --git a/Handler/NewUser.hs b/Handler/NewUser.hs
index 57bb7fd..b39f35b 100644
--- a/Handler/NewUser.hs
+++ b/Handler/NewUser.hs
@@ -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
diff --git a/Handler/Restock.hs b/Handler/Restock.hs
index d45c659..389c41d 100644
--- a/Handler/Restock.hs
+++ b/Handler/Restock.hs
@@ -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
diff --git a/Handler/Summary.hs b/Handler/Summary.hs
index 4e2a85e..7b59d4a 100644
--- a/Handler/Summary.hs
+++ b/Handler/Summary.hs
@@ -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
diff --git a/config/models b/config/models
index fb79c9c..2e1bd65 100644
--- a/config/models
+++ b/config/models
@@ -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)
diff --git a/config/routes b/config/routes
index 9713584..dcabcfc 100644
--- a/config/routes
+++ b/config/routes
@@ -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
diff --git a/messages/cz.msg b/messages/cz.msg
index f4c0af7..abadd22 100644
--- a/messages/cz.msg
+++ b/messages/cz.msg
@@ -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
diff --git a/messages/de.msg b/messages/de.msg
index 56d081b..8106443 100644
--- a/messages/de.msg
+++ b/messages/de.msg
@@ -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
diff --git a/messages/en.msg b/messages/en.msg
index c29a7e4..f6f02fa 100644
--- a/messages/en.msg
+++ b/messages/en.msg
@@ -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
diff --git a/messages/pl.msg b/messages/pl.msg
index af80977..db38b9d 100644
--- a/messages/pl.msg
+++ b/messages/pl.msg
@@ -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
diff --git a/static/css/main.css b/static/css/main.css
index 203d48b..6e637fb 100644
--- a/static/css/main.css
+++ b/static/css/main.css
@@ -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;
diff --git a/templates/avatars.hamlet b/templates/avatars.hamlet
new file mode 100644
index 0000000..486fe1c
--- /dev/null
+++ b/templates/avatars.hamlet
@@ -0,0 +1,18 @@
+$doctype 5
+
+
+ Avatars
+
+$if null avatars
+
+ _{MsgNoAvatars}
+$else
+ $forall (Entity aId avatar) <- avatars
+
+
+ #{avatarIdent avatar}
+
+
+