adding delete event form, regenerateSessionId before login and csrf protection

Author: soupi

src/Web/Gathering/Actions/Auth.hs

@@ -101,18 +101,19 @@ adminHook = do
 signInAction :: (ListContains n IsGuest xs, NotInList User xs ~ 'True) => Action (HVect xs) ()
 signInAction = do
   title <- cfgTitle . appConfig <$> getState
+  csrfToken <- getCsrfToken
   let
     -- | Display the form to the user
     formView mErr view = do
       formViewer title "Sign-in" FS.signinFormView mErr view
 
   -- Run the form
-  form <- runForm "loginForm" FS.signinForm
+  form <- runForm "" (FS.signinForm csrfToken)
   -- validate the form.
   -- Nothing means failure. will display the form view back to the user when validation fails.
   case form of
     (view, Nothing) ->
-      lucid $ formView Nothing view
+      formView Nothing view
     -- If basic validation of fields succeeds, continue to check validation against db
 
     (view, Just FS.Signin{sinLogin, sinPassword}) -> do
@@ -125,15 +126,15 @@ signInAction = do
           text $ T.pack (show err)
 
         Right Nothing ->
-          lucid $ formView (pure $ p_ "Invalid user name/email.") view
+          formView (pure $ p_ "Invalid user name/email.") view
 
         Right (Just (user, pass)) -> do
           if verifyPassword (T.encodeUtf8 sinPassword) pass
             then do -- success - create the session for the user
               makeSession (userId user) $
                 redirect "/"
             else
-              lucid $ formView (pure $ p_ "Invalid password.") view
+              formView (pure $ p_ "Invalid password.") view
 
 -- | Describe the action to do when a user wants to sign up for the system:
 --
@@ -144,18 +145,19 @@ signInAction = do
 signUpAction :: (ListContains n IsGuest xs, NotInList User xs ~ 'True) => Action (HVect xs) ()
 signUpAction = do
   title <- cfgTitle . appConfig <$> getState
+  csrfToken <- getCsrfToken
   let
     -- | Display the form to the user
     formView mErr view = do
       formViewer title "Sign-up" FS.signupFormView mErr view
 
   -- Run the form
-  form <- runForm "registerForm" FS.signupForm
+  form <- runForm "" (FS.signupForm csrfToken)
   -- validate the form.
   -- Nothing means failure. will display the form view back to the user when validation fails.
   case form of
     (view, Nothing) ->
-      lucid $ formView Nothing view
+      formView Nothing view
 
     -- Case for bots
     (_, Just (FS.Signup { supUsername, supSpamHoneyPot }))
@@ -173,11 +175,11 @@ signUpAction = do
           text $ T.pack (show err)
 
         Right (Just _) -> do
-            lucid $ formView (pure $ p_ "Username or email already exists.") view
+            formView (pure $ p_ "Username or email already exists.") view
 
         Right Nothing
           | pass /= passConfirm ->
-            lucid $ formView (pure $ p_ "Passwords do not match.") view
+            formView (pure $ p_ "Passwords do not match.") view
 
         -- User does not exists and passwords match. try to create a new user
         Right Nothing -> do
@@ -240,6 +242,7 @@ verificationAction key email = do
 makeSession :: (ListContains n IsGuest xs, NotInList User xs ~ 'True)
             => UserId -> Action (HVect xs) () -> Action (HVect xs) ()
 makeSession uid act = do
+  sessionRegenerateId
   sessRes <- runQuery $ Sql.run $ upsertUserSession uid
   case sessRes of
     Left err -> do

src/Web/Gathering/Actions/Events.hs

@@ -55,18 +55,19 @@ displayEvents getEventsQuery mUser = do
 newEventAction :: (ListContains n User xs, ListContains m IsAdmin xs) => Action (HVect xs) ()
 newEventAction = do
   title <- cfgTitle . appConfig <$> getState
+  csrfToken <- getCsrfToken
   let
     -- | Display the form to the user
     formView mErr view = do
       formViewer title "Sign-up" (editEventFormView path "Create") mErr view
 
   -- Run the form
-  form <- runForm path (editEventForm Nothing)
+  form <- runForm "" (editEventForm csrfToken Nothing)
   -- validate the form.
   -- Nothing means failure. will display the form view back to the user when validation fails.
   case form of
     (view, Nothing) ->
-      lucid $ formView Nothing view
+      formView Nothing view
     -- If basic validation of fields succeeds, continue to check validation against db
 
     (_, Just (EditEvent name desc loc mWhen mDur))
@@ -96,6 +97,7 @@ newEventAction = do
 editEventAction :: (ListContains n User xs, ListContains m IsAdmin xs) => EventId -> Action (HVect xs) ()
 editEventAction eid = do
   title <- cfgTitle . appConfig <$> getState
+  csrfToken <- getCsrfToken
   let
     -- | Display the form to the user
     formView mErr view = do
@@ -113,12 +115,12 @@ editEventAction eid = do
     Right (Just editedEvent) -> do
 
       -- Run the form
-      form <- runForm path (editEventForm $ Just $ eventToEditEvent editedEvent)
+      form <- runForm "" (editEventForm csrfToken $ Just $ eventToEditEvent editedEvent)
       -- validate the form.
       -- Nothing means failure. will display the form view back to the user when validation fails.
       case form of
         (view, Nothing) ->
-          lucid $ formView Nothing view
+          formView Nothing view
         -- If basic validation of fields succeeds, continue to check validation against db
 
         (_, Just (EditEvent name desc loc mWhen mDur))
@@ -143,9 +145,11 @@ editEventAction eid = do
 
 -- | Describe the action to do when a user wants to delete an existing event
 --
-removeEventAction :: (ListContains n User xs, ListContains m IsAdmin xs) => EventId -> Action (HVect xs) ()
-removeEventAction eid = do
+deleteEventAction :: (ListContains n User xs, ListContains m IsAdmin xs) => EventId -> Action (HVect xs) ()
+deleteEventAction eid = do
   mEvent <- runQuery $ Sql.run (getEventById eid)
+  csrfToken <- getCsrfToken
+
   case mEvent of
     -- @TODO this is an internal error that we should take care of internally
     Left err ->
@@ -155,14 +159,33 @@ removeEventAction eid = do
       text "Event does not exist"
 
     Right (Just event) -> do
-      result <- runQuery $ Sql.run (removeEvent event)
-      case result of
-        -- @TODO this is an internal error that we should take care of internally
-        Left err -> do
-          text $ T.pack (show err)
-
-        Right _ ->
-          redirect "/"
+
+      let
+        path = "/event/" <> T.pack (show eid) <> "/delete"
+        -- | Display the form to the user
+        formView mErr view = do
+          formViewer "Delete Event" "Delete" (deleteEventFormView path $ eventName event) mErr view
+
+      -- Run the form
+      form <- runForm "" (deleteEventForm csrfToken)
+      -- validate the form.
+      -- Nothing means failure. will display the form view back to the user when validation fails.
+      case form of
+        (view, Nothing) ->
+          formView Nothing view
+
+        (_, Just (DeleteEvent False)) -> do
+          redirect $ "/event/" <> T.pack (show $ eventId event)
+
+        (_, Just (DeleteEvent True)) -> do
+          result <- runQuery $ Sql.run (removeEvent event)
+          case result of
+            -- @TODO this is an internal error that we should take care of internally
+            Left err -> do
+              text $ T.pack (show err)
+
+            Right _ ->
+              redirect "/"
 
 
 reportEventParsingError :: EditEvent -> Action (HVect xs) ()

src/Web/Gathering/Actions/Utils.hs

@@ -7,14 +7,18 @@ module Web.Gathering.Actions.Utils where
 import Data.Text
 import Data.Monoid
 import Web.Gathering.Html
+import Web.Gathering.Types
+import Web.Spock.Lucid (lucid)
+import Web.Spock
 
 -- | Display the form to the user
-formViewer :: Text -> Text -> (t -> Html) -> Maybe Html -> t -> Html
+formViewer :: Text -> Text -> (t -> Html) -> Maybe Html -> t -> Action v ()
 formViewer title actionName form mErr view = do
-  template
-    (title <> " - " <> actionName)
-    title
-    (pure ())
-    $ do
-      maybe (pure ()) id mErr
-      form view
+  lucid $ do
+    template
+      (title <> " - " <> actionName)
+      title
+      (pure ())
+      $ do
+        maybe (pure ()) id mErr
+        form view

src/Web/Gathering/Database.hs

@@ -299,15 +299,14 @@ updateEvent event = do
 removeEvent :: Event -> Sql.Session ()
 removeEvent event = do
   removeAttendants event
+  removeNewEvent event
   Sql.query (eventId event) $
     Sql.statement
       "delete from events where event_id = $1"
       (SqlE.value SqlE.int4)
       SqlD.unit
       True
 
-  removeNewEvent event
-
 removeNewEvent :: Event -> Sql.Session ()
 removeNewEvent event =
   Sql.query (eventId event) $

src/Web/Gathering/Forms/EditEvent.hs

@@ -15,6 +15,7 @@ import Web.Gathering.Model
 import Web.Gathering.Forms.Utils
 import Web.Gathering.Html (Html)
 
+import Data.Monoid
 import Data.Maybe (isNothing)
 import Text.Digestive ((.:))
 import qualified Text.Digestive as D
@@ -38,9 +39,10 @@ data EditEvent
   deriving (Show)
 
 -- | Definition of a form and it's validation
-editEventForm :: Monad m => Maybe EditEvent -> D.Form Html m EditEvent
-editEventForm mEvent = EditEvent
-    <$> "name"     .: D.check "Cannot be empty" (not . T.null) (fmap (fmap trim) D.text (eEventName     <$> mEvent))
+editEventForm :: Monad m => T.Text -> Maybe EditEvent -> D.Form Html m EditEvent
+editEventForm csrfToken mEvent = const EditEvent
+    <$> "__csrf_token" .: D.text (Just csrfToken)
+    <*> "name"     .: D.check "Cannot be empty" (not . T.null) (fmap (fmap trim) D.text (eEventName     <$> mEvent))
     <*> "desc"     .: D.check "Cannot be empty" (not . T.null) (fmap (fmap trim) D.text (eEventDesc     <$> mEvent))
     <*> "location" .: D.check "Cannot be empty" (not . T.null) (fmap (fmap trim) D.text (eEventLocation <$> mEvent))
     <*> "datetime" .: D.validateM validateDateTime (fmap (fmap trim) D.text (eEventDateTime <$> mEvent))
@@ -92,6 +94,8 @@ editEventFormView formName submitText view =
       D.inputTextArea
         (Just 60) (Just 80) "desc" view
 
+    D.inputHidden "__csrf_token" view
+
     D.inputSubmit submitText
 
 
@@ -104,3 +108,32 @@ eventToEditEvent Event { eventName, eventDesc, eventLocation, eventDateTime, eve
     (formatDateTime eventDateTime)
     (formatDiffTime eventDuration)
 
+
+-- Delete event --
+
+-- | Definition of a delete event data type
+data DeleteEvent
+  = DeleteEvent
+  { imSure :: Bool
+  }
+  deriving (Show)
+
+-- | Definition of a form and it's validation
+deleteEventForm :: Monad m => T.Text -> D.Form Html m DeleteEvent
+deleteEventForm csrfToken = const DeleteEvent
+    <$> "__csrf_token" .: D.text (Just csrfToken)
+    <*> "imsure" .: D.bool Nothing
+
+
+-- | Defining the view for the delete event form
+deleteEventFormView :: T.Text -> T.Text -> D.View Html -> Html
+deleteEventFormView formName eName view =
+  D.form view formName $ do
+    H.div_ $ do
+      D.inputCheckbox "imsure" view
+      D.label         "imsure" view . H.toHtml $
+        "I'm sure I want to delete the event '" <> eName <> "'."
+
+    D.inputHidden "__csrf_token" view
+
+    D.inputSubmit "Delete Event"

src/Web/Gathering/Forms/Sign.hs

@@ -56,9 +56,10 @@ data Signup
   } deriving (Show)
 
 -- | Definition of a form and it's validation
-signupForm :: Monad m => D.Form Html m Signup
-signupForm = Signup
-    <$> "name"      .: D.validateM validateName (fmap (fmap trim) D.text Nothing)
+signupForm :: Monad m => T.Text -> D.Form Html m Signup
+signupForm csrfToken = const Signup
+    <$> "__csrf_token" .: D.text (Just csrfToken)
+    <*> "name"      .: D.validateM validateName (fmap (fmap trim) D.text Nothing)
     <*> "email"     .: D.validateM validateMail (fmap (fmap trim) D.text Nothing)
     <*> "password1" .: D.validateM validatePass (fmap (fmap trim) D.text Nothing)
     <*> "password2" .: D.text Nothing
@@ -121,6 +122,8 @@ signupFormView view =
     H.div_ $ do
       D.inputHidden "shp" view
 
+    D.inputHidden "__csrf_token" view
+
     D.inputSubmit "Sign-up"
 
 -------------
@@ -135,9 +138,10 @@ data Signin
   } deriving (Show)
 
 -- | Defining the form
-signinForm :: Monad m => D.Form Html m Signin
-signinForm = Signin
-    <$> "login"    .: fmap (fmap trim) D.text Nothing
+signinForm :: Monad m => T.Text -> D.Form Html m Signin
+signinForm csrfToken = const Signin
+    <$> "__csrf_token" .: D.text (Just csrfToken)
+    <*> "login"    .: fmap (fmap trim) D.text Nothing
     <*> "password" .: fmap (fmap trim) D.text Nothing
 
 -- | Defining the view for the signin form
@@ -155,5 +159,7 @@ signinFormView view =
       D.label         "password" view "Password: "
       D.inputPassword "password" view
 
+    D.inputHidden "__csrf_token" view
+
     D.inputSubmit "Sign-in"
 

src/Web/Gathering/Router.hs

@@ -103,8 +103,8 @@ appRouter = prehook baseHook $ do
       getpost ("event" <//> var <//> "edit") $ \(eid :: EventId) ->
         editEventAction eid
 
-      get ("event" <//> var <//> "delete") $ \(eid :: EventId) ->
-        removeEventAction eid
+      getpost ("event" <//> var <//> "delete") $ \(eid :: EventId) ->
+        deleteEventAction eid
 
 -----------
 -- Hooks --

src/Web/Gathering/Run.hs

@@ -40,7 +40,8 @@ run = do
   (uncurry AppState -> state) <- parseArgs
   print state
   let connstr = cfgDbConnStr (appConfig state)
-  spockCfg <- defaultSpockCfg EmptySession (PCConn $ hasqlPool connstr) state
+  spockCfg <- (\cfg -> cfg { spc_csrfProtection = True, spc_csrfPostName = ".__csrf_token" })
+          <$> defaultSpockCfg EmptySession (PCConn $ hasqlPool connstr) state
 
   -- Background workers
   void $ forkIO $ newEventsWorker state

src/Web/Gathering/Utils.hs

@@ -3,8 +3,11 @@
 
 module Web.Gathering.Utils where
 
+import Turtle (err)
 import Data.Time
+import Data.Monoid
 import qualified Data.Text as T
+import qualified Data.Text.IO as T
 
 fst3 :: (a, b, c) -> a
 fst3 (a, _, _) = a
@@ -59,3 +62,12 @@ parseDiffTime (trim -> T.unpack -> duration) =
   where
     isDigit = (`elem` ['0'..'9'])
 
+putStrTime :: T.Text -> IO ()
+putStrTime txt = do
+  t <- getCurrentTime
+  T.putStrLn ("[" <> formatDateTime t <> "] - " <> txt)
+
+errTime :: T.Text -> IO ()
+errTime txt = do
+  t <- getCurrentTime
+  err ("<<" <> formatDateTime t <> ">> - " <> txt)