chore(form): add knownUserField accepting known users only
This commit is contained in:
parent
a1d7f16427
commit
c2e0f6b2b8
@ -50,6 +50,7 @@ module Database.Esqueleto.Utils
|
||||
, subSelectCountDistinct
|
||||
, selectCountRows, selectCountDistinct
|
||||
, str2text, str2text'
|
||||
, str2citext
|
||||
, num2text --, text2num
|
||||
, day, day', dayMaybe, interval, diffDays, diffTimes
|
||||
, exprLift
|
||||
@ -79,6 +80,7 @@ import Database.Esqueleto.Utils.TH
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy as Lazy (Text)
|
||||
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Crypto.Hash (Digest, SHA256)
|
||||
|
||||
@ -537,6 +539,7 @@ strip = E.unsafeSqlFunction "TRIM"
|
||||
|
||||
infix 4 `ciEq`
|
||||
|
||||
-- Note that this function is unnecessary if the DB type is citext
|
||||
ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
|
||||
ciEq a b = lower a E.==. lower b
|
||||
|
||||
@ -750,6 +753,9 @@ str2text = E.unsafeSqlCastAs "text"
|
||||
str2text' :: E.SqlString a => E.SqlExpr (E.Value (Maybe a)) -> E.SqlExpr (E.Value (Maybe Text))
|
||||
str2text' = E.unsafeSqlCastAs "text"
|
||||
|
||||
str2citext :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (CI.CI Text))
|
||||
str2citext = E.unsafeSqlCastAs "citext"
|
||||
|
||||
-- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
|
||||
num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
|
||||
num2text = E.unsafeSqlCastAs "text"
|
||||
|
||||
@ -1920,6 +1920,109 @@ userField onlySuggested suggestions = Field{..}
|
||||
Nothing -> E.true
|
||||
|
||||
|
||||
knownUserField :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Bool -- ^ Only resolve suggested users?
|
||||
-> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
|
||||
-> Field m UserId
|
||||
knownUserField onlySuggested suggestions = Field{..}
|
||||
where
|
||||
lookupExpr
|
||||
| onlySuggested = suggestions
|
||||
| otherwise = Just $ E.from return
|
||||
|
||||
fieldEnctype = UrlEncoded
|
||||
fieldView theId name attrs val isReq = do
|
||||
val' <- case val of
|
||||
Left t -> return t
|
||||
Right uid -> case lookupExpr of
|
||||
Nothing -> return mempty
|
||||
Just lookupExpr' -> do
|
||||
dbRes <- liftHandler . runDB . E.select $ do
|
||||
user <- lookupExpr'
|
||||
E.where_ $ user E.^. UserId E.==. E.val uid
|
||||
return $ user E.^. UserEmail
|
||||
case dbRes of
|
||||
[E.Value email] -> return $ CI.original email
|
||||
_other -> return mempty
|
||||
|
||||
datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
|
||||
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|
||||
|]
|
||||
|
||||
whenIsJust suggestions $ \suggestions' -> do
|
||||
suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
|
||||
user <- suggestions'
|
||||
return ( E.case_
|
||||
[ E.when_ (unique user $ Left UserDisplayEmail)
|
||||
E.then_ (user E.^. UserDisplayEmail)
|
||||
, E.when_ (unique user $ Left UserEmail)
|
||||
E.then_ (user E.^. UserEmail)
|
||||
]
|
||||
( E.else_ $ user E.^. UserIdent)
|
||||
, user E.^. UserDisplayName
|
||||
)
|
||||
[whamlet|
|
||||
$newline never
|
||||
<datalist id=#{datalistId}>
|
||||
$forall (email, dName) <- suggestedEmails
|
||||
<option value=#{email}>
|
||||
#{email} (#{dName})
|
||||
|]
|
||||
fieldParse (filter (not . Text.null) . fmap T.strip -> t : _) _
|
||||
| Just lookupExpr' <- lookupExpr = do
|
||||
let cit = CI.mk t
|
||||
dbRes <- liftHandler $ runDBRead $ E.select $ E.distinct $ do
|
||||
user <- lookupExpr'
|
||||
E.where_ $ user E.^. UserIdent `E.ciEq` E.val cit
|
||||
E.||. ( user E.^. UserDisplayEmail E.==. E.val cit
|
||||
E.&&. unique user (Left UserDisplayEmail)
|
||||
)
|
||||
E.||. ( user E.^. UserEmail E.==. E.val cit
|
||||
E.&&. unique user (Left UserEmail)
|
||||
)
|
||||
E.||. ( user E.^. UserMatrikelnummer E.==. E.justVal t
|
||||
E.&&. unique user (Right UserMatrikelnummer)
|
||||
)
|
||||
E.||. ( user E.^. UserCompanyPersonalNumber E.==. E.justVal t
|
||||
E.&&. unique user (Right UserCompanyPersonalNumber)
|
||||
)
|
||||
E.limit 3 -- just to optimize the query
|
||||
return $ user E.^. UserId
|
||||
case dbRes of
|
||||
[uid] -> return $ Right $ Just $ E.unValue uid
|
||||
[] -> return $ Left $ SomeMessage $ MsgInvalidEmail t -- TODO: placeholder only, better error message
|
||||
_ -> return $ Left $ SomeMessage MsgAmbiguousEmail -- TODO: placeholder only, better error message
|
||||
|
||||
-- email <- either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . CI.mk . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
|
||||
unique user (Left field) | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
|
||||
user' <- lookupExpr'
|
||||
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
|
||||
E.&&. ( user' E.^. UserIdent E.==. user E.^. field
|
||||
E.||. user' E.^. UserEmail E.==. user E.^. field
|
||||
E.||. user' E.^. UserDisplayEmail E.==. user E.^. field
|
||||
E.||. E.str2citext (user' E.^. UserMatrikelnummer) E.==. user E.^. field
|
||||
E.||. E.str2citext (user' E.^. UserCompanyPersonalNumber) E.==. user E.^. field
|
||||
)
|
||||
unique user (Right field) | Just lookupExpr' <- lookupExpr = E.not_ . E.exists $ do
|
||||
user' <- lookupExpr'
|
||||
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
|
||||
E.&&. ( user' E.^. UserIdent E.==. E.str2citext (user E.^. field)
|
||||
E.||. user' E.^. UserEmail E.==. E.str2citext (user E.^. field)
|
||||
E.||. user' E.^. UserDisplayEmail E.==. E.str2citext (user E.^. field)
|
||||
E.||. user' E.^. UserMatrikelnummer E.==. user E.^. field
|
||||
E.||. user' E.^. UserCompanyPersonalNumber E.==. user E.^. field
|
||||
)
|
||||
unique _ _ = E.true
|
||||
|
||||
|
||||
examResultField :: forall m res.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
|
||||
Loading…
Reference in New Issue
Block a user