58 lines
No EOL
1.9 KiB
Haskell
58 lines
No EOL
1.9 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
|
{-# HLINT ignore "Replace case with fromMaybe" #-}
|
|
module Handler.Group where
|
|
|
|
import Import
|
|
import Text.Read
|
|
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
|
getGroupR :: Handler Html
|
|
getGroupR = do
|
|
userId <- getUserId
|
|
groups <- getGroups userId
|
|
defaultLayout $ do
|
|
setTitle "Groups"
|
|
$(widgetFile "group")
|
|
postAddGroupR :: Handler Html
|
|
postAddGroupR = do
|
|
g <- runInputPost $ ireq textField "group"
|
|
-- TODO: in a newer version, put insertUnique_
|
|
user <- getUserId
|
|
_ <- runDB $ do
|
|
currentTime <- liftIO getCurrentTime
|
|
gId <- insert $ Group g currentTime
|
|
success <- insertUnique $ GroupUser user gId
|
|
when (isNothing success) $ delete gId
|
|
redirect GroupR
|
|
|
|
getEditGroupR :: Handler Html
|
|
getEditGroupR = do
|
|
userId <- getUserId
|
|
groups <- getGroups userId
|
|
defaultLayout $ do
|
|
let a e = pack $ show $ fromSqlKey $ entityKey e ::Text
|
|
setTitle "Groups"
|
|
$(widgetFile "edit-group")
|
|
postEditGroupR :: Handler Html
|
|
postEditGroupR = do
|
|
-- TODO: not implemented yet
|
|
-- title <- runInputPost $ ireq textField "title"
|
|
-- users <- runInputPost $ ireq textField "users"
|
|
-- id <- runInputPost $ ireq intField "id"
|
|
-- let key = toSqlKey id
|
|
-- runDB $ update key [GroupGroup =. title]
|
|
redirect EditGroupR
|
|
postDeleteGroupR :: Handler Html
|
|
postDeleteGroupR = do
|
|
text <- lookupPostParams "ids"
|
|
let ints = map (read . unpack) text :: [Int64]
|
|
let ids = map toSqlKey ints :: [GroupId]
|
|
-- TODO: make sure the user has access to it aswell (this only works now for single user), and handle group owned by many
|
|
runDB $ deleteWhere [GroupId <-. ids]
|
|
redirect EditGroupR |