chore(form): add knownUserField accepting known users only

src/Database/Esqueleto/Utils.hs

@@ -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"

src/Handler/Utils/Form.hs

@@ -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