Functionality to hijack users

messages/de.msg

@@ -3,6 +3,7 @@ BtnAbort: Abbrechen
 BtnDelete: Löschen
 BtnRegister: Anmelden
 BtnDeregister: Abmelden
+BtnHijack: Sitzung übernehmen
 
 RegisterFrom: Anmeldungen von
 RegisterTo: Anmeldungen bis

routes

@@ -35,6 +35,7 @@
 /users                      UsersR            GET             -- no tags, i.e. admins only
 /admin/test                 AdminTestR        GET POST
 /admin/user/#CryptoUUIDUser AdminUserR        GET
+/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
 /info                       VersionR          GET             !free
 
 /profile                    ProfileR          GET POST        !free                             !free

src/Handler/Users.hs

@@ -14,11 +14,17 @@ import Handler.Utils
 
 import qualified Data.Map as Map
 
-import Colonnade hiding (fromMaybe)
-
 import qualified Database.Esqueleto as E
 
 
+hijackUserForm :: UserId -> Form UserId
+hijackUserForm uid csrf = do
+  cID <- encrypt uid
+  (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
+  (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing 
+
+  return (uid <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
+
 getUsersR :: Handler Html
 getUsersR = do
   let
@@ -53,6 +59,13 @@ getUsersR = do
                       <li>#{sh}
                 |]
           }
+      , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
+          (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
+          cID <- encrypt uid
+          [whamlet|
+            <form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
+              ^{hijackView}
+          |]
       ]
     psValidator = def
       & defaultSorting [("display-name", SortAsc)]
@@ -73,3 +86,17 @@ getUsersR = do
   defaultLayout $ do
     setTitleI MsgUserListTitle
     $(widgetFile "users")
+
+postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
+postAdminHijackUserR cID = do
+  uid <- decrypt cID
+  ((hijackRes, _), _) <- runFormPost $ hijackUserForm uid
+
+  case hijackRes of
+    FormSuccess uid'
+      | uid' == uid -> do
+          User{..} <- runDB $ get404 uid
+          setCredsRedirect $ Creds "dummy" (userPlugin <> ":" <> userIdent) []
+      | otherwise -> error "This should be impossible by definition of `hijackUserForm`"
+    FormFailure errs -> toTypedContent <$> mapM_ (addMessage "error" . toHtml) errs
+    FormMissing -> return $ toTypedContent ()

src/Handler/Utils/Form.hs

@@ -142,6 +142,18 @@ instance Button RegisterButton where
   cssClass BtnRegister   = BCPrimary
   cssClass BtnDeregister = BCDanger
 
+data AdminHijackUserButton = BtnHijack
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece AdminHijackUserButton where
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button AdminHijackUserButton where
+  label BtnHijack = [whamlet|_{MsgBtnHijack}|]
+
+  cssClass BtnHijack = BCDefault
+
 
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
 -- data LinkButton = LinkButton (Route UniWorX)