diff --git a/Application.hs b/Application.hs index 716c7df..9ebdb48 100644 --- a/Application.hs +++ b/Application.hs @@ -57,6 +57,7 @@ import Handler.Supplier import Handler.SupplierActions import Handler.Demand import Handler.Statistics +import Handler.Pinentry -- 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/NewUser.hs b/Handler/NewUser.hs index a71bab6..db1d8f1 100644 --- a/Handler/NewUser.hs +++ b/Handler/NewUser.hs @@ -70,6 +70,7 @@ newUserForm today = User <*> pure today <*> aopt emailField (bfs MsgEmailNotify) Nothing <*> aopt (selectField avatars) (bfs MsgSelectAvatar) Nothing + <*> aopt passwordField (bfs MsgUserPin) Nothing <* bootstrapSubmit (msgToBSSubmit MsgSubmit) where avatars = do @@ -81,6 +82,7 @@ data UserConf = UserConf , userConfEmail :: Maybe Text , userConfAvatar :: Maybe AvatarId , userConfBarcode :: Maybe [Text] + , userConfPIN :: Maybe Text } getModifyUserR :: UserId -> Handler Html @@ -115,6 +117,7 @@ postModifyUserR uId = [ UserIdent =. userConfIdent uc , UserEmail =. userConfEmail uc , UserAvatar =. userConfAvatar uc + , UserPin =. userConfPIN uc ] liftIO $ notify user (userConfEmail uc) handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc) @@ -134,6 +137,7 @@ modifyUserForm user bs = UserConf <*> aopt emailField (bfs MsgEmailNotify) (Just $ userEmail user) <*> aopt (selectField avatars) (bfs MsgSelectAvatar) (Just $ userAvatar user) <*> aopt barcodeField (bfs MsgBarcodeField) (Just $ Just bs) + <*> aopt passwordField (bfs MsgUserPin) Nothing <* bootstrapSubmit (msgToBSSubmit MsgSubmit) where avatars = do diff --git a/Handler/Pinentry.hs b/Handler/Pinentry.hs new file mode 100644 index 0000000..0aa6ffb --- /dev/null +++ b/Handler/Pinentry.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DoAndIfThenElse #-} +module Handler.Pinentry where + +import Import + +import Handler.Common + +import qualified Data.Text as T (pack) + +getPinentryR :: UserId -> Handler Html +getPinentryR uId = + isUser uId HomeR >>= (\user -> do + case userPin user of + Just pin -> do + (pinWidget, enctype) <- generateFormPost + $ renderBootstrap3 BootstrapBasicForm + $ pinentryForm + defaultLayout $ do + [whamlet| +