From dc03afa84de6740098469218a78283c18e851018 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 8 Jul 2018 15:38:52 +0200
Subject: [PATCH] Functionality to hijack users

---
 messages/de.msg           |  1 +
 routes                    |  1 +
 src/Handler/Users.hs      | 31 +++++++++++++++++++++++++++++--
 src/Handler/Utils/Form.hs | 12 ++++++++++++
 4 files changed, 43 insertions(+), 2 deletions(-)

diff --git a/messages/de.msg b/messages/de.msg
index c97852f20..ea407972e 100644
--- a/messages/de.msg
+++ b/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
diff --git a/routes b/routes
index 48cc4578b..778805719 100644
--- a/routes
+++ b/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
diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs
index 31faf23af..ba2ad0022 100644
--- a/src/Handler/Users.hs
+++ b/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 ()
diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs
index 9b1ae65dc..080e9023f 100644
--- a/src/Handler/Utils/Form.hs
+++ b/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)