I am developing my first application with Yesod and I am creating some CRUD api to start.
I have a model that looks like
User json
...
Activity json
userId UserId
...
where userId is a foreign key.
I need to create an endpoint to be able to create a new Activity and the client needs to be able to specify the userId.
To do this I am using a form like
postCreateActivityR :: Hadler Value
postCreateActivityR = do
activity <- runInputPost $ Activity
<$> ...
<*> ireq textField "userId"
...
Doing so I get an error like the following:
Couldn't match type ‘Text’ with ‘Key User’ expected type: FormInput (HandlerT App IO) (Key User)
Is there a standard way to solve this?
If you are working with a SQL backend, there is toSqlKey in Database.Persist.Sql module. Since you are given Text, you first need to convert it into Int64 using Data.Text.Read.
For the records, this is how I solved it in the end
I had to create a new field
userIdField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UserId
userIdField = Field
{ fieldParse = parseHelper $ \s ->
case signed decimal s of
Right (a, "") -> Right $ toSqlKey a
_ -> Left $ MsgInvalidInteger s
, fieldView = \_ _ _ _ _ -> ""
, fieldEnctype = UrlEncoded
}
and then use it like
<*> ireq userIdField "userId"
Related
I am a Haskell newbie, and I am thinking about how I can modularize my Rest application, which essentially passes around a ReaderT everywhere. I have devised a primitive working example of how to do that (below) using ExistentialQuantification. In a comment to a relevant answer, user MathematicalOrchid claimed something similar to be an anti-pattern. Is this an anti-pattern? In newbie terms, can you explain why if so and show a better alternative?
{-# LANGUAGE ExistentialQuantification #-}
import Control.Monad.Reader
import Control.Monad.Trans
import Data.List (intersect)
data Config = Config Int Bool
data User = Jane | John | Robot deriving (Show)
listUsers = [Jane, John, Robot]
class Database d where
search :: d -> String -> IO [User]
fetch :: d -> Int -> IO (Maybe User)
data LiveDb = LiveDb
instance Database LiveDb where
search d q = return $ filter ((q==) . intersect q . show) listUsers
fetch d i = return $ if i<3 then Just $ listUsers!!i else Nothing
data TestDb = TestDb
instance Database TestDb where
search _ _ = return [Robot]
fetch _ _ = return $ Just Robot
data Context = forall d. (Database d) => Context {
db :: d
, config :: Config
}
liveContext = Context { db = LiveDb, config = Config 123 True }
testContext = Context { db = TestDb, config = Config 123 True }
runApi :: String -> ReaderT Context IO String
runApi query = do
Context { db = db } <- ask
liftIO . fmap show $ search db query
main = do
let q = "Jn"
putStrLn $ "searching users for " ++ q
liveResult <- runReaderT (runApi q) liveContext
putStrLn $ "live result " ++ liveResult
testResult <- runReaderT (runApi q) testContext
putStrLn $ "test result " ++ testResult
Edit: a working example based on the accepted answer
import Control.Monad.Reader
import Control.Monad.Trans
import Data.List (intersect)
data Config = Config Int Bool
data User = Jane | John | Robot deriving (Show)
listUsers = [Jane, John, Robot]
data Database = Database {
search :: String -> IO [User]
, fetch :: Int -> IO (Maybe User)
}
liveDb :: Database
liveDb = Database search fetch where
search q = return $ filter ((q==) . intersect q . show) listUsers
fetch i = return $ if i<3 then Just $ listUsers!!i else Nothing
testDb :: Database
testDb = Database search fetch where
search _ = return [Robot]
fetch _ = return $ Just Robot
data Context = Context {
db :: Database
, config :: Config
}
liveContext = Context { db = liveDb, config = Config 123 True }
testContext = Context { db = testDb, config = Config 123 True }
runApi :: String -> ReaderT Context IO String
runApi query = do
d <- fmap db $ ask
liftIO . fmap show $ search d $ query
main = do
let q = "Jn"
putStrLn $ "searching users for " ++ q
liveResult <- runReaderT (runApi q) liveContext
putStrLn $ "live result " ++ liveResult
testResult <- runReaderT (runApi q) testContext
putStrLn $ "test result " ++ testResult
When you pattern-match on a Context, you get in the db field a value of a type that you can never know precisely; all you're allowed to know about it is that it's a Database instance, and thus you can use that class' methods with it. But that means that, from the point of view of the Context type, the existential d type affords it no more capabilities than this type does:
-- The "record of methods" pattern
data Database =
Database { search :: String -> IO [User]
, fetch :: Int -> IO (Maybe User)
}
liveDb :: Database
liveDb = Database search fetch
where search d q = return $ filter ((q==) . intersect q . show) listUsers
fetch d i = return $ if i<3 then Just $ listUsers!!i else Nothing
testDb :: Database
testDb = Database search fetch
where search _ _ = return [Robot]
fetch _ _ = return (Just Robot)
data Context =
Context { db :: Database
, config :: Config
}
That's the core argument against using existential types in the manner that you've done—there is a completely equivalent alternative that doesn't require existential types.
The argument against existential types is quite simple (and strong): often, you can avoid both the existential type and type class machinery, and use plain functions instead.
This is clearly the case where your class has the form
class D a where
method1 :: a -> T1
method2 :: a -> T2
-- ...
as in the posted Database example, since its instances can be replaced by values in a plain record type
data D = {
method1 :: T1
, method2 :: T2
-- ...
}
This is, essentially, the solution by #LuisCasillas .
However, note that the above translation relies on types T1,T2 not to depend on a. What if this is not the case? E.g. what if we had
class Database d where
search :: d -> String -> [User]
fetch :: d -> Int -> Maybe User
insert :: d -> User -> d
The above is a "pure" (no-IO) interface to a database, also allowing updates through insert. An instance could then be
data LiveDb = LiveDb [User]
instance Database LiveDb where
search (LiveDb d) q = filter ((q==) . intersect q . show) d
fetch (LiveDb d) i = case drop i d of [] -> Nothing ; (x:_) -> Just x
insert (LiveDb d) u = LiveDb (u:d)
Note that here we do use the parameter d, unlike in the original case where it was a placeholder.
Can we do without classes and existentials here?
data Database =
Database { search :: String -> [User]
, fetch :: Int -> Maybe User
, insert :: User -> Database
}
Notice that above we are returning an abstract Database in insert. This interface is more general than the existential-classy one, since it allows insert to change the underlying representation for the database. I.e., insert could move from a list-based representation to a tree-based one. This is like having insert acting from the existentially-quantified Database to itself, instead of from a concrete instance to itself.
Anyway, let's write LiveDb in the record-style way:
liveDb :: Database
liveDb = Database (search' listUsers) (fetch' listUsers) (insert' listUsers)
where search' d q = filter ((q==) . intersect q . show) d
fetch' d i = case drop i d of [] -> Nothing ; (x:_) -> Just x
insert' d u = Database (search' d') (fetch' d') (insert' d')
where d' = u:d
listUsers = [Jane, John, Robot]
Above I had to pass the underlying state d to each function, and in insert I had to update such state.
Overall, I find the above more involved than the instance Database LiveDb methods, which require no state-passing. Surely, we can apply a little refactoring and clarify the code:
makeLiveDb :: [User] -> Database
makeLiveDb d = Database search fetch insert
where search q = filter ((q==) . intersect q . show) d
fetch i = case drop i d of [] -> Nothing ; (x:_) -> Just x
insert u = makeLiveDb (u:d)
liveDb :: Database
liveDb = makeLiveDb [Jane, John, Robot]
This is a bit better, yet not as simple than the plain instance. There is no straightforward winner in this case, and which style to use is a matter of personal preference.
Personally, I stay away from existentially-quantified classes as much as possible, since in many, many cases they lose to much simpler approaches. However, I'm not dogmatic about them, and allow myself to use the "anti-pattern" when the alternative starts becoming too clumsy.
As an alternative, one could use an external function working at the abstract level, only:
data Database =
Database { search :: String -> [User]
-- let's neglect other methods for simplicity's sake
}
insert :: Database -> User -> Database
insert (Database s) u = Database s'
where s' str = s str ++ [ u | show u == str ] -- or something similar
The advantage of doing this is that insert works on the abstract Database, whatever its underlying data structure is. The disadvantage is that, in this way, insert can only access the database through its "methods", and can only work by building closures upon closures. If we also implemented a remove method, applying insert and delete many times will cause a larger and larger memory footprint, since remove can not remove the element from the underlying data structure, but can only build yet another closure which skips over the removed element. More pragmatically, it would be as if insert and remove simply appended to a log, and search scanned the log to see if the most recent action on an element was an insertion or a removal. This will not have a great performance.
I’m new to Yesod and would like to create a custom field in which I need to do a query.
My model is the following:
Article
artname Text
title Text
body Text
parent ArticleId Maybe
UniqueArt artname
deriving Typeable
I want to create a "parent field" in which the user enters an artname instead of a numerical id, but it will be the real id which will be stored in the database.
I cannot use checkMMap since the invert function works outside of IO.
From what I understood of the field processing, fieldParse takes the value entered by the user and tries to convert it to an ArticleId while fieldView takes an ArticleId and shows a more human version.
What I’ve come up until now is the following:
parentField :: Field sub ArticleId
parentField = Field
{ fieldParse = \rawVals _ -> do
let (name:[]) = rawVals
marticle <- runDB $ getBy (UniqueArt name)
case marticle of
Nothing -> return $ (Left . SomeMessage) ("Article name invalid." :: Text)
Just article -> return $ (Right . Just) (entityKey article)
, fieldView = \idAttr nameAttr attrs eResult isReq ->
case eResult of
Right key -> do
marticle <- runDB $ get key
let name = case marticle of
Just article -> Right (articleArtname article)
Nothing -> Left ("Article key invalid." :: Text)
(fieldView textField) idAttr nameAttr attrs name isReq
Left _ -> (fieldView textField) idAttr nameAttr attrs eResult isReq
}
GHC doesn’t like the marticle <- runDB $ get key line and gives me the following error:
Handler/Article.hs:50:21:
Couldn't match type ‘HandlerT site1 IO’
with ‘WidgetT (HandlerSite sub) IO’
Expected type: HandlerT site1 IO (Maybe Article)
-> (Maybe Article -> HandlerT site1 IO ())
-> WidgetT (HandlerSite sub) IO ()
Actual type: HandlerT site1 IO (Maybe Article)
-> (Maybe Article -> HandlerT site1 IO ()) -> HandlerT site1 IO ()
Relevant bindings include
parentField :: Field sub ArticleId
(bound at Handler/Article.hs:39:1)
In a stmt of a 'do' block: marticle <- runDB $ get key
In the expression:
do { marticle <- runDB $ get key;
let name = ...;
(fieldView textField) idAttr nameAttr attrs name isReq }
In a case alternative:
Right key
-> do { marticle <- runDB $ get key;
let name = ...;
(fieldView textField) idAttr nameAttr attrs name isReq }
Any idea ? Is it a lift I forgot ?
In order to be able to do queries inside fieldParse and fieldView, I needed some adjustments:
the parentField signature must be fully specified. The YesodPersist and YesodPersistBackend constraints needs to be set because of the runDB calls.
the query inside fieldView needs to be translated to a Widget because it is working inside a function that outputs a Widget. That’s why the handlerToWidget function is used.
the original code was based on the textField field but this imposed other constraints. Therefore I defined my own whamlet.
the fieldEnctype was missing.
Here is the updated source code:
parentField :: YesodPersist site
=> YesodPersistBackend site ~ SqlBackend
=> RenderMessage (HandlerSite (HandlerT site IO)) FormMessage
=> Field (HandlerT site IO) ArticleId
parentField = Field
{ fieldParse = \rawVals _ -> do
let (name:[]) = rawVals
articleM <- runDB $ getBy (UniqueArt name)
return $ case articleM of
Nothing -> (Left . SomeMessage) ("Article name invalid." :: Text)
Just article -> (Right . Just) (entityKey article)
, fieldView = \ident name attrs resultE isReq ->
case resultE of
Right key -> do
articleM <- handlerToWidget . runDB $ get key
let value = case articleM of
Just article -> Right (articleArtname article)
Nothing -> Left ("Article key invalid." :: Text)
parentHtml ident name attrs value isReq
Left err -> parentHtml ident name attrs (Left err) isReq
, fieldEnctype = UrlEncoded
}
where parentHtml ident name attrs val isReq =
[whamlet|$newline never
<input id="#{ident}"
name="#{name}"
*{attrs}
type="text"
:isReq:required
value="#{either id id val}">
|]
I'd like to convert the Field (HandlerT site IO) Day of the jqueryDayField into a Field (HandlerT site IO) UTCTime with diffTime 0 since I am using mongodb as my database and Day just produces an integer value in the store and no actual date format.
i.e. I have something like this in my form code:
<*> areq (dayToUTC $ (jqueryDayField def
{ jdsChangeYear = True -- give a year dropdown
, jdsChangeMonth = True
, jdsYearRange = "2000:"
})) (fieldSettingsLabel MsgNewEntryDate) Nothing
where dayToUTC would do the conversion. Or should I use a different approach?
My solution so far is just havin a custom jqueryUTCField :: (RenderMessage site FormMessage, YesodJquery site) => JqueryDaySettings -> Field (HandlerT site IO) UTCTime function but I don't feel like this is necessarily the best solution.
Something like the following should work:
dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
I'm using the yesod scaffold. I'm struggeling a bit with how to get a value from the settings.yml file,
The relevant part of the settings.yml file looks like this,
Default: &defaults
host: "*4" # any IPv4 host
port: 3000
approot: "http://localhost:3000"
admins: ["someEmail#gmail.com", "someOtherEmail#gmail.com"]
And then in my Foundation.hs file I have a method to check if the users email (using googleauth) matches a pre-specified email,
admins = ["someEmail#gmail.com", "someOtherEmail#gmail.com"]
isAdmin (Just (Entity _ user)) | elem (userIdent user) admins = Authorized
| otherwise = AuthenticationRequired
isAdmin Nothing = AuthenticationRequired
My goal is to replace the admins function with the one from the the settings.yml file because it seems more appropriate.
Any help on doing this would be greatly appreciated!
EDIT:
Okay, I've come as far as fetching the newly made "extra" with the following method,
admins = do
madmins <- extraAdmins getExtra
case madmins of
Nothing -> return Nothing
Just admins -> return admins
But the GHC throws this at me,
Foundation.hs:161:28:
Couldn't match expected type `Extra'
with actual type `Handler Extra'
In the first argument of `extraAdmins', namely `getExtra'
In a stmt of a 'do' block: madmins <- extraAdmins getExtra
In the expression:
do { madmins <- extraAdmins getExtra;
case madmins of {
Nothing -> return Nothing
Just admins -> return admins } }
Is there a way to convert it from Handler Extra to Extra, or am I simply doing it the wrong way?
At the end of the Settings.hs file in the scaffolding, there's the definition of Extra and how to parse it:
data Extra = Extra
{ extraCopyright :: Text
, extraAnalytics :: Maybe Text -- ^ Google Analytics
} deriving Show
parseExtra :: DefaultEnv -> Object -> Parser Extra
parseExtra _ o = Extra
<$> o .: "copyright"
<*> o .:? "analytics"
You can add the extra data you want to this structure and parse it there. From the rest of your app, you can access this value with getExtra (defined in Foundation.hs).
You're a bit confused about the types of getExtra and extraAdmins.
I'm guessing they're like this:
getExtra :: Handler Extra
extraAdmins :: Extra -> [Text] -- maybe?
If so, something like this should work:
isAdmin :: User -> Handler Bool
isAdmin u = do
extra <- getExtra
return $ userIdent u `elem` extraAdmins extra
Would it be possible to give checkM the following type instead:
checkM :: RenderMessage master msg =>
(a -> GHandler sub master (Either msg b)) ->
Field sub master a -> Field sub master b
The reason is the following:
I have a form that asks for a user name. Using checkM, I immediately look up in the database whether the entered user exists:
userField = checkM userexists textField
userexists input = do
mbuser <- runDB $ getBy $ UniqueName input
return $ case mbuser of
Nothing -> Left ("This user does not exist!" :: Text)
(Just (Entity uid _)) -> Right input
-- I would like to write "return Right uid" above!
However, I can only return input::Text, so right after the form has accepted the user input, I need to do another database lookup for the same name to get the database key for that user, which is what I really wanted.
(This example is largely simplified. Essentially, I want to get the database keys for a series of different user inputs (all in one form), which I can only ask as TextFields, or not?)
The reason the type signature looks that way is that there are two aspects to a Field: how you parse it, and how you render it. checkM only changes how you parse the field, but the rendering function (fieldView) remains unmodified. Therefore, the value needs to keep the same type.
The simplest way I can think of to get the behavior you want is to have a function which can get a value of the old type from a value of the new type. That way, given a new value, we can just apply that function to it and get the old value for rendering purposes. Here's what the code would look like:
checkM' :: RenderMessage master msg
=> (a -> GHandler sub master (Either msg b))
-> (b -> a)
-> Field sub master a
-> Field sub master b
checkM' f inv field = field
{ fieldParse = \ts -> do
e1 <- fieldParse field ts
case e1 of
Left msg -> return $ Left msg
Right Nothing -> return $ Right Nothing
Right (Just a) -> fmap (either (Left . SomeMessage) (Right . Just)) $ f a
, fieldView = \i n a eres req -> fieldView field i n a (fmap inv eres) req
}
So in your case, you could use it by changing the last line in userexists to:
(Just (Entity uid _)) -> Right (input, uid)
and then defining userField as
userField = checkM' userexists fst textField
I think a function like checkM makes sense to include in yesod-form, but hopefully with a better name ;).