I have a form where a user can update its username. A username should be unique. I thought of using the standard validation as mentioned in the Yesod book: Forms, but I don't get my head around it... Relevant database definition:
Profile
username Text
user UserId
UniqueProfile user
UniqueUsername username
Without validation, the user will receive an error-page (because of the username-uniqueness constraint on db-level). I want it to be more friendly.
How can I solve this? I was thinking that the validation should count the rows with the filled in username and should differ from the logged in UserId (a user can update other items too and keep its username). But how do I get that result to be used in the Left part of the validation?
Solution:
profileForm :: Maybe ProfileForm -> Form ProfileForm
profileForm mpf = renderBootstrap $ ProfileForm
<$> areq usernameField (FieldSettings {fsLabel = "Username", fsTooltip = Nothing, fsId = Nothing, fsName = Nothing, fsAttrs = [("autofocus","autofocus")]}) (pfUsername <$> mpf)
where
unav x = do
(Entity uid _) <- requireAuth
usernamecount <- runDB $ count [ ProfileUsername ==. x
, ProfileUser !=. uid ]
return $ if usernamecount > 0
then Left ("Username already taken" :: Text)
else Right x
usernameField = checkM unav textField
I think you're looking for the checkM function, which will allow you to perform arbitrary actions during the validation of a field.
Related
EDIT: For those with similar ailments, I found this is related to the "Extensible Records Problem", something I will personally research more into.
EDIT2: I have started to solve this (weeks later now) by being pretty explicit about data types, and having multiple data types per semantic unit of data. For example, if the database holds an X, my code has an XAction for representing things I want to do with an X, and XResponse for relaying Xs to an http client. And then I need to build the supporting code for shuttling bits between instances. Not ideal, but, I like that it's explicit, and hopefully when my models crystallize, it shouldn't really need much up keep, and should be very reliable.
I'm not sure what the correct level of abstraction is for tackling this problem (ie records? or Yesod?) So I'll just lay out the simple case.
Simple Case / TL;DR
I want to decode a request body into a type
data Comment = Comment {userid :: ..., comment :: ...}
but actually I don't want the request body to contain userid, the server will supply that based on their Auth Headers, (or wherever I want to get data to default fill a field).
So they actually pass me something like:
data SimpleComment = SimpleComment {comment :: ...} deriving (Generic, FromJSON)
And I turn it into a Comment. But maintaining both nearly-identical types simultaneously is a hassle, and not DRY.
How do I solve this problem?
Details on Problem
I have a record type:
data Comment = Comment {userid :: ..., comment :: ...}
I have a POST route:
postCommentR :: Handler Value
postCommentR = do
c <- requireJsonBody :: (Handler Comment)
insertedComment <- runDB ...
returnJson insertedComment
Notice that the Route requires that the user supply their userid (in the Comment type, which is at least redundant since their id is associated with their auth headers. At worst, it means I need to check that users are adding their own id, or throwing away their supplied id, in which case why did they supply it in the first case.
So, I want a record type that's Comment minus userid, but I don't know how to do that intelligently.
My Current (awful but working) Solution
So I made a custom type with derived FromJSON (for the request body) which is almost completely redundant with the Comment type.
data SimpleComment = SimpleComment {comment :: ...} deriving (Generic, FromJSON)
Then my new route needs to decode the request body according to this, and then merge a SimpleComment with a userid field to make it a Comment:
postComment2R :: Handler Value
postComment2R = do
c <- requireJsonBody :: (Handler SimpleComment)
(uid, _) requireAuthPair
insertedComment <- runDB $ insertEntity (Comment { commentUserid = uid
, commentComment = comment c})
returnJson ...
Talk about boilerplate. And my use case is more complex than this simple Comment type.
If it factors in, you might be able to tell, I'm using the Yesod Scaffolding.
What I usually do to get a type minus a field is just to have a function which take that field and return the type. In your case you just need to declare an JSON instance for UserId -> Comment. Ok it doesn't seem natural and you have to go it manually but it actually works really well, especially as there is only one field of type UserId in Comment.
A solution I like is to use a wrapper for things that come from/go to the DB:
data Authenticated a = Authenticated
{ uid :: Uid
, thing :: a
} deriving (Show)
Then you can have Comment be just SimpleComment and turn it into an Authenticated Comment once you know the user id.
I'm also looking for a nice way to solve this. :-)
What I usually do in my code is to operate directly on the Aeson's type Value. This is some of the sample code taken from my current project:
import qualified Data.HashMap.Strict as HM
removeKey :: Text -> Value -> Value
removeKey key (Object xs) = Object $ HM.delete key xs
removeKey _ ys = ys
I directly operate on the value Object and remove the particular key present in the javascript object.
And in the Yesod handler code, I do this processing:
myHandler :: Handler RepJson
myHandler = do
userId <- insert $ User "sibi" 23
guser <- getJuser user
let guser' = removeKey "someId" $ toJSON guser
return $ repJson $ object [ "details" .= guser' ]
In some cases, I actually want to add some specific key to the outgoing JSON object. For those, I have specific helper functions defined which operate on the type Value. While this is not perfect, it has been helping me to avoid a lot of boilerplate code.
Let's suppose that I have a persistent type and want to project some value from this type:
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
User
name Text
email Text
|]
...
getName :: Entity User -> Text
getName (Entity uid vals) = userName vals
The problem is, if I generate lenses for said type, using mkPersist sqlSettings {mpsGenerateLenses = True}, I'll need to add a underscore in the beginning of each projection function or use the lenses getter:
getName :: Entity User -> Text
getName (Entity uid vals) = _userName vals
getName' :: Entity User -> Text
getName (Entity uid vals) = vals ^. userName
Firstly, how can I revert that to the default, userName vals, and add the underscore to use the lenses getter, vals ^. _userName?
Secondly, why is this this way and not the other way around?
Firstly, how can I revert that to the default, userName vals, and add the underscore to use the lenses getter, vals ^. _userName?
Database.Persist.TH does not offer that option (to see what it might look like if it existed, cf. Control.Lens.TH), so, assuming that you won't fork the library over this, there doesn't seem to be a way. (By the way, looking for mpsGenerateLenses in the source will show exactly where the underscores are added.)
Secondly, why is this this way and not the other way around?
Presumably because the library assumes that if you generate the lenses you will use them everywhere instead of the record accessors/labels, including for getting the value of the field. The only cosmetic suggestion I have is that, if the change of writing order from _userName vals to vals ^. userName bothers you, you might prefer using view rather than (^.), as in view userName vals.
Problem description
I've been unable to get a compiling example of using Yesod.Auth.Hardcoded. My problem is in trying to interrogate the user in a hamlet template. My Foundation.hs is set up as per the documentation in the link for hardcoded. My handler looks like this:
getHomeR :: Handler Html
getHomeR = do
uid <- maybeAuthId
(widget, enctype) <- generateFormPost . renderBootstrap3 BootstrapBasicForm $ blurbForm Nothing
currentPost <- runDB $ selectFirst [] [Desc BlogId]
currentBlurb <- runDB $ selectFirst [] [Desc BlurbId]
defaultLayout $ do
setTitle "My site"
addScriptRemote "https://ajax.googleapis.com/ajax/libs/jquery/1.11.2/jquery.min.js"
addScriptRemote "https://cdnjs.cloudflare.com/ajax/libs/twitter-bootstrap/3.2.0/js/collapse.js"
$(widgetFile "homepage")
My site compiles and renders happily until I try to do anything useful with the uid being assigned in the do block above.
What I've tried
I've tried both the $maybe and $case constructs in the hamlet documentation. $maybe looked like this:
$maybe user <- uid
<p>There's a name
$nothing
<p>No name
This succeeded regardless of whether I logged in as the hardcoded user.
The $case version looked like this:
$case uid
$of Left _
<p>There's no name
$of Right username
<p>It worked
and failed with:
Exception when trying to run compile-time code:
Inside a $case there may only be $of. Use '$of _' for a wildcard.
Code: widgetFile "homepage"
In the splice: $(widgetFile "homepage")
Question(s)
Am I setting the uid correctly in my handler code and, if so, how should I access the hardcoded SiteManager in my templates?
As often posting the question made me think of an answer, though I'd still be grateful for any better ones. Using a combination of $maybe and $case like so:
$maybe user <- uid
$case user
$of Left _
<p>There's no name
$of Right username
<p>There might be a name of #{username}
$nothing
<p>No name
got me the correct username. Please post another answer if there is a better way.
The AuthId type here is Either UserId String.
A Right value represents a "hardcoded" user which does not appear in the User table. A Left value represents a User row in the Users table.
If you want to show a name for an AuthId, you can call getAuthEntity which returns an Either User SiteManager and then process it like this:
getUserName :: Either User SiteManager -> String
getUserName (Left user) = ...get the name field from user...
getUserName (Right sitemgr) = manUserName sitemgr
I found out when I try to register an email on RegisterR which already exists, instead of displaying an error message, that the user already exists, it sends an an email confirmation request to the given email address, just like if I asked for a password reset.
After going through the sources, I found out that registerHelper checks if the email exists, and if it does, it sends a verify email even if it's already verified.
-- [...]
mecreds <- lift $ getEmailCreds identifier
registerCreds <-
case mecreds of
Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email)
Just (EmailCreds lid _ _ Nothing email) -> do
key <- liftIO $ randomKey y
lift $ setVerifyKey lid key
return $ Just (lid, key, email)
Nothing
| allowUsername -> return Nothing
| otherwise -> do
key <- liftIO $ randomKey y
lid <- lift $ addUnverified identifier key
return $ Just (lid, key, identifier)
case registerCreds of
Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier)
Just (lid, verKey, email) -> do
render <- getUrlRender
let verUrl = render $ verify (toPathPiece lid) verKey
lift $ sendVerifyEmail email verKey verUrl
lift $ confirmationEmailSentResponse identifier
-- [...]
Source: https://hackage.haskell.org/package/yesod-auth-1.4.3.1/docs/src/Yesod-Auth-Email.html#registerHelper
Since registerCreds is a Just when the email exists and it has a key, it sends the verify email again to the user, whiche he/she can use as a password reset link.
My questions are:
Why does it work this way? This basically makes registering an already existing email address equal requesting password reset. I'm sure it has a good reason, and it makes me wonder if I'm using Auth.Email correctly.
Yesod.Auth.Email.postRegisterR gets called immediately when the request arrives - where do I have a chance to check that the email address already exists, and inform the user?
EDIT: It turned out I was looking at the source of a much older version: I updated the question. In yesod-auth-1.4.3, this code is in registerHelper, not in postRegisterR.
After discussing it on #yesod, this is probably a bug, so I filed an issue on it:
https://github.com/yesodweb/yesod/issues/948
I'd like to display a list of items in a webpage, along with associated details from a separate table (with a many-to-one relationship). How do I do this in Yesod? I am using the default scaffolding. The upshot is that runDB cannot be nested in a WidgetT context — or so I think.
To make this more concrete, how do I define the function featuresAssociatedWith to use in the following hamlet code:
<h2> Cars
$forall Entity carId car <- carList
<div class="car-item">
<h3> #{carYear car} #{carMake car} #{carModel car}
<ul>
$forall feature <- featuresAssociatedWith carId
<li> #{feature}
Given the following models:
Car
make Text
model Text
year Int
CarFeature
car CarId
text Text
UniqueCF car text
Here is the current handler function
getCarListR :: Handler Html
getCarListR = do
carList <- runDB $ selectList [] [Asc CarOrder]
liftIO $ print $ length carList
defaultLayout $ do
setTitle "Cars"
$(widgetFile "carList")
It seems most natural to embed a runDB query in the Widget this way, but again, this isn't possible:
featuresAssocWith :: CarId -> [Entity CarFeature]
featuresAssocWith carID = selectList [CarFeatureCar ==. carID] []
Hamlet is designed to not allow you to perform actions like database queries inside of it. Instead, you'll need to perform the query outside of hamlet, and then pass in a list of tuples of car info together with the data from the associated table.