Compare commits
2 commits
3511f257e6
...
f0951506a0
| Author | SHA1 | Date | |
|---|---|---|---|
| f0951506a0 | |||
| 2353d2fdc9 |
7 changed files with 330 additions and 303 deletions
|
|
@ -6,7 +6,7 @@
|
||||||
/favicon.ico FaviconR GET
|
/favicon.ico FaviconR GET
|
||||||
/robots.txt RobotsR GET
|
/robots.txt RobotsR GET
|
||||||
|
|
||||||
/ HomeR GET
|
/ GroupR GET
|
||||||
/group/#GroupId TodolistR GET
|
/group/#GroupId TodolistR GET
|
||||||
|
|
||||||
/add AddGroupR POST
|
/add AddGroupR POST
|
||||||
|
|
|
||||||
|
|
@ -44,7 +44,9 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
|
||||||
-- Import all relevant handler modules here.
|
-- Import all relevant handler modules here.
|
||||||
-- Don't forget to add new modules to your cabal file!
|
-- Don't forget to add new modules to your cabal file!
|
||||||
import Handler.Common
|
import Handler.Common
|
||||||
import Handler.TodoEntry
|
import Handler.Group
|
||||||
|
import Handler.Todolist
|
||||||
|
import Handler.TodolistItem
|
||||||
|
|
||||||
-- This line actually creates our YesodDispatch instance. It is the second half
|
-- This line actually creates our YesodDispatch instance. It is the second half
|
||||||
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
|
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
|
||||||
|
|
|
||||||
|
|
@ -191,3 +191,25 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
|
||||||
-- https://github.com/yesodweb/yesod/wiki/Sending-email
|
-- https://github.com/yesodweb/yesod/wiki/Sending-email
|
||||||
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
|
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
|
||||||
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
|
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
|
||||||
|
|
||||||
|
|
||||||
|
-- TODO: complete implementation should short circuit if multi user is on but no user exist
|
||||||
|
getUserId :: HandlerFor App (Key User)
|
||||||
|
getUserId = do
|
||||||
|
mName <- lookupHeader "Remote-User"
|
||||||
|
mUser <- case mName of
|
||||||
|
-- TODO: make remote user an argument to make it usable not only with authelia, and maybe do a check for good mesure when nothing is found ?
|
||||||
|
Just name -> runDB $ insertBy $ User (decodeUtf8 name)
|
||||||
|
Nothing -> runDB $ insertBy $ User "single-user"
|
||||||
|
case mUser of
|
||||||
|
Left (Entity userId _) -> return userId
|
||||||
|
Right userId -> return userId
|
||||||
|
|
||||||
|
dbIfAuth :: GroupId -> ReaderT SqlBackend (HandlerFor App) b -> HandlerFor App b
|
||||||
|
dbIfAuth groupId action = do
|
||||||
|
-- TODO: decide if we prefer fast (rawSql) or safe (type safe persist query) after in production latency tests
|
||||||
|
-- TODO: optimize the persist implementation anyway
|
||||||
|
user <- getUserId
|
||||||
|
result <- runDB $ selectFirst [GroupUserUser ==. user, GroupUserGroupId ==. groupId] []
|
||||||
|
if isNothing result then permissionDenied "you are not logged in or you dont have access to this group"
|
||||||
|
else runDB action
|
||||||
88
src/Handler/Group.hs
Normal file
88
src/Handler/Group.hs
Normal file
|
|
@ -0,0 +1,88 @@
|
||||||
|
{-# 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, rawSql)
|
||||||
|
getGroupR :: Handler Html
|
||||||
|
getGroupR = do
|
||||||
|
userId <- getUserId
|
||||||
|
groups <- getGroups userId
|
||||||
|
mToken <- fmap reqToken getRequest
|
||||||
|
defaultLayout $ do
|
||||||
|
setTitle "Groups"
|
||||||
|
[whamlet|
|
||||||
|
<a href=@{GroupR}>Home
|
||||||
|
<ul>
|
||||||
|
$forall group <- groups
|
||||||
|
<li>
|
||||||
|
<a href=@{TodolistR $ entityKey group}>#{(groupGroup . entityVal) group}
|
||||||
|
<form action=@{AddGroupR} method="post">
|
||||||
|
<input type="text" name="group" placeholder="new group">
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<button type="submit">add
|
||||||
|
<a href=@{EditGroupR}>Edit
|
||||||
|
|]
|
||||||
|
|
||||||
|
postAddGroupR :: Handler Html
|
||||||
|
postAddGroupR = do
|
||||||
|
g <- runInputPost $ ireq textField "group"
|
||||||
|
-- TODO: in a newer version, put insertUnique_
|
||||||
|
user <- getUserId
|
||||||
|
_ <- runDB $ do
|
||||||
|
gId <- insert $ Group g
|
||||||
|
success <- insertUnique $ GroupUser user gId
|
||||||
|
when (isNothing success) $ delete gId
|
||||||
|
redirect GroupR
|
||||||
|
|
||||||
|
getEditGroupR :: Handler Html
|
||||||
|
getEditGroupR = do
|
||||||
|
userId <- getUserId
|
||||||
|
groups <- getGroups userId
|
||||||
|
mToken <- fmap reqToken getRequest
|
||||||
|
defaultLayout $ do
|
||||||
|
let a e = pack $ show $ fromSqlKey $ entityKey e ::Text
|
||||||
|
setTitle "Groups"
|
||||||
|
[whamlet|
|
||||||
|
<form action=@{DeleteGroupR} method="POST">
|
||||||
|
<ul>
|
||||||
|
$forall group <- groups
|
||||||
|
<li>
|
||||||
|
<input type="checkbox" name="ids" value="#{a group}">
|
||||||
|
<a href="">#{(groupGroup . entityVal) group}
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<button type=submit>Delete selected
|
||||||
|
<a href=@{GroupR}>Back
|
||||||
|
|]
|
||||||
|
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
|
||||||
|
|
||||||
|
getGroups :: Key User -> Handler [Entity Group]
|
||||||
|
getGroups userId =
|
||||||
|
let sql = "SELECT ?? FROM \"group\" JOIN group_user gu ON \"group\".id = gu.group_id WHERE gu.user = ?" in
|
||||||
|
runDB $ rawSql sql [toPersistValue userId]
|
||||||
|
|
@ -1,301 +0,0 @@
|
||||||
{-# 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.TodoEntry where
|
|
||||||
|
|
||||||
import Import
|
|
||||||
import Text.Read
|
|
||||||
import Database.Persist.Sql (rawExecute, fromSqlKey, toSqlKey, rawSql)
|
|
||||||
-- TODO: move this back to another handler
|
|
||||||
getHomeR :: Handler Html
|
|
||||||
getHomeR = do
|
|
||||||
userId <- getUserId
|
|
||||||
groups <- getGroups userId
|
|
||||||
mToken <- fmap reqToken getRequest
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitle "Groups"
|
|
||||||
[whamlet|
|
|
||||||
<a href=@{HomeR}>Home
|
|
||||||
<ul>
|
|
||||||
$forall group <- groups
|
|
||||||
<li>
|
|
||||||
<a href=@{TodolistR $ entityKey group}>#{(groupGroup . entityVal) group}
|
|
||||||
<form action=@{AddGroupR} method="post">
|
|
||||||
<input type="text" name="group" placeholder="new group">
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<button type="submit">add
|
|
||||||
<a href=@{EditGroupR}>Edit
|
|
||||||
|]
|
|
||||||
|
|
||||||
postAddGroupR :: Handler Html
|
|
||||||
postAddGroupR = do
|
|
||||||
g <- runInputPost $ ireq textField "group"
|
|
||||||
-- TODO: in a newer version, put insertUnique_
|
|
||||||
user <- getUserId
|
|
||||||
_ <- runDB $ do
|
|
||||||
gId <- insert $ Group g
|
|
||||||
success <- insertUnique $ GroupUser user gId
|
|
||||||
when (isNothing success) $ delete gId
|
|
||||||
redirect HomeR
|
|
||||||
postAddTodolistR :: GroupId -> Handler Html
|
|
||||||
postAddTodolistR groupId = do
|
|
||||||
list <- runInputPost $ ireq textField "list"
|
|
||||||
-- TODO: in a newer version, put insertUnique_
|
|
||||||
_ <- dbIfAuth groupId (insertUnique $ Todolist groupId list)
|
|
||||||
redirect $ TodolistR groupId
|
|
||||||
|
|
||||||
-- TODO: move this to a new handler file
|
|
||||||
getTodolistR :: GroupId -> Handler Html
|
|
||||||
getTodolistR groupId = do
|
|
||||||
lists <- dbIfAuth groupId (selectList [TodolistGroupId ==. groupId] [])
|
|
||||||
mToken <- fmap reqToken getRequest
|
|
||||||
defaultLayout $ do
|
|
||||||
let getTitle = todolistTitle . entityVal
|
|
||||||
setTitle "todolist"
|
|
||||||
[whamlet|
|
|
||||||
<a href=@{HomeR}>Home
|
|
||||||
<ul>
|
|
||||||
$forall list <- lists
|
|
||||||
<li>
|
|
||||||
<a href=@{TodolistItemsR groupId (entityKey list)}>#{getTitle list}
|
|
||||||
<form action=@{AddTodolistR groupId} method="post">
|
|
||||||
<input type="text" name="list" placeholder="new list">
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<button type="submit">add
|
|
||||||
<form action=@{AddUserR groupId} method="post">
|
|
||||||
<input type="text" name="user" placeholder="new user">
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<button type="submit">share
|
|
||||||
<a href=@{EditTodolistR groupId}>Edit
|
|
||||||
|]
|
|
||||||
|
|
||||||
getTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
getTodolistItemsR groupId todolistId = do
|
|
||||||
mSortOption <- lookupSession "sort"
|
|
||||||
items <- case mSortOption of
|
|
||||||
(Just "value") -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Desc TodolistItemValue, Asc TodolistItemId])
|
|
||||||
_ -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Asc TodolistItemId])
|
|
||||||
|
|
||||||
mToken <- fmap reqToken getRequest
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitle "items"
|
|
||||||
[whamlet|
|
|
||||||
<a href=@{HomeR}>Home
|
|
||||||
|
|
||||||
<a href=@{TodolistR groupId}>Lists
|
|
||||||
<ul>
|
|
||||||
$forall item <- items
|
|
||||||
<li>
|
|
||||||
<form action=@{CheckTodolistItemR groupId todolistId (entityKey item)} method="POST">
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<button type="submit">#{getText item}
|
|
||||||
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
|
||||||
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
|
||||||
<input type="text" name="item" placeholder="new item">
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<button type="submit">add
|
|
||||||
<form action=@{TrimTodolistItemsR groupId todolistId} method="post">
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<button type="submit">trim
|
|
||||||
<form action=@{SortTodolistItemsR groupId todolistId} method="post">
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<button type="submit">sort
|
|
||||||
<a href=@{EditTodolistItemsR groupId todolistId}>Edit
|
|
||||||
|]
|
|
||||||
|
|
||||||
|
|
||||||
postCheckTodolistItemR :: GroupId -> TodolistId -> TodolistItemId -> Handler Html
|
|
||||||
postCheckTodolistItemR groupId todolistId todolistItemId = do
|
|
||||||
dbIfAuth groupId (rawExecute "UPDATE todolist_item SET value = NOT value WHERE id = ?" [toPersistValue todolistItemId])
|
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
|
||||||
|
|
||||||
|
|
||||||
postAddTodolistItemR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
postAddTodolistItemR groupId todolistId = do
|
|
||||||
item <- runInputPost $ ireq textField "item"
|
|
||||||
_ <- dbIfAuth groupId (insert_ $ TodolistItem todolistId False item)
|
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
|
||||||
|
|
||||||
getEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
getEditTodolistItemsR groupId todolistId = do
|
|
||||||
items <- dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [])
|
|
||||||
mToken <- fmap reqToken getRequest
|
|
||||||
let text = unlines $ map getText items
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitle "edit"
|
|
||||||
[whamlet|
|
|
||||||
<form action=@{EditTodolistItemsR groupId todolistId} method=POST>
|
|
||||||
<label for="edit text area">Edit todolist
|
|
||||||
<br>
|
|
||||||
<textarea id="edit text area" name=text rows=30 cols=50 placeholder="[x] wake up1 [x] eat [ ] sleep [ ] repeat">#{text}
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<br>
|
|
||||||
<button type="submit">edit
|
|
||||||
|]
|
|
||||||
postEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
postEditTodolistItemsR groupId todolistId = do
|
|
||||||
mText <- runInputPost $ iopt textField "text"
|
|
||||||
let xs = case mText of
|
|
||||||
(Just text) -> getItems text todolistId
|
|
||||||
Nothing -> []
|
|
||||||
dbIfAuth groupId (do
|
|
||||||
deleteWhere [TodolistItemTodolistId ==. todolistId]
|
|
||||||
insertMany_ xs)
|
|
||||||
|
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
|
||||||
|
|
||||||
getEditTodolistR :: GroupId -> Handler Html
|
|
||||||
getEditTodolistR groupId = do
|
|
||||||
lists <- runDB $
|
|
||||||
selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
|
|
||||||
mToken <- fmap reqToken getRequest
|
|
||||||
defaultLayout $ do
|
|
||||||
let keyToText e = pack $ show $ fromSqlKey $ entityKey e ::Text
|
|
||||||
setTitle "Groups"
|
|
||||||
[whamlet|
|
|
||||||
<form action=@{DeleteTodolistR groupId} method="POST">
|
|
||||||
<ul>
|
|
||||||
$forall list <- lists
|
|
||||||
<li>
|
|
||||||
<input type="checkbox" name="ids" value="#{keyToText list}">
|
|
||||||
<a href="">#{(todolistTitle . entityVal) list}
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<button type=submit>Delete selected
|
|
||||||
<a href=@{TodolistR groupId}>Back
|
|
||||||
|]
|
|
||||||
postDeleteTodolistR :: GroupId -> Handler Html
|
|
||||||
postDeleteTodolistR groupId = do
|
|
||||||
text <- lookupPostParams "ids"
|
|
||||||
let ints = map (read . unpack) text :: [Int64]
|
|
||||||
let ids = map toSqlKey ints :: [TodolistId]
|
|
||||||
dbIfAuth groupId (deleteWhere [TodolistId <-. ids])
|
|
||||||
redirect $ EditTodolistR groupId
|
|
||||||
postEditTodolistR :: GroupId -> Handler Html
|
|
||||||
postEditTodolistR groupId = error "not done yet"
|
|
||||||
|
|
||||||
getEditGroupR :: Handler Html
|
|
||||||
getEditGroupR = do
|
|
||||||
userId <- getUserId
|
|
||||||
groups <- getGroups userId
|
|
||||||
mToken <- fmap reqToken getRequest
|
|
||||||
defaultLayout $ do
|
|
||||||
let a e = pack $ show $ fromSqlKey $ entityKey e ::Text
|
|
||||||
setTitle "Groups"
|
|
||||||
[whamlet|
|
|
||||||
<form action=@{DeleteGroupR} method="POST">
|
|
||||||
<ul>
|
|
||||||
$forall group <- groups
|
|
||||||
<li>
|
|
||||||
<input type="checkbox" name="ids" value="#{a group}">
|
|
||||||
<a href="">#{(groupGroup . entityVal) group}
|
|
||||||
$maybe token <- mToken
|
|
||||||
<input type="hidden" name="_token" value="#{token}">
|
|
||||||
<button type=submit>Delete selected
|
|
||||||
<a href=@{HomeR}>Back
|
|
||||||
|]
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
||||||
postAddUserR :: GroupId -> Handler Html
|
|
||||||
postAddUserR groupId= do
|
|
||||||
user <- runInputPost $ ireq textField "user"
|
|
||||||
_ <- dbIfAuth groupId (do
|
|
||||||
mUserId <- getBy $ UniqueName user
|
|
||||||
case mUserId of
|
|
||||||
Nothing -> --handle error
|
|
||||||
redirect $ TodolistR groupId
|
|
||||||
Just userId -> insert $ GroupUser (entityKey userId) groupId
|
|
||||||
)
|
|
||||||
redirect $ TodolistR groupId
|
|
||||||
|
|
||||||
getText :: Entity TodolistItem -> Text
|
|
||||||
getText item =
|
|
||||||
if value then "[x] " <> name
|
|
||||||
else "[ ] " <> name
|
|
||||||
where
|
|
||||||
value = (todolistItemValue . entityVal) item
|
|
||||||
name = (todolistItemName . entityVal) item
|
|
||||||
|
|
||||||
getItems :: Text -> TodolistId -> [TodolistItem]
|
|
||||||
getItems text todolistId = map read (lines text)
|
|
||||||
where read line = do
|
|
||||||
let (d, n) = splitAt 4 line
|
|
||||||
let
|
|
||||||
value = case d of
|
|
||||||
"[x] " -> True
|
|
||||||
"[ ] " -> False
|
|
||||||
_ -> error "Invalid status"
|
|
||||||
name = case n of
|
|
||||||
"" -> error "empty name"
|
|
||||||
something -> filter (/= '\r') something
|
|
||||||
TodolistItem todolistId value name
|
|
||||||
|
|
||||||
postTrimTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
postTrimTodolistItemsR groupId todolistId = do
|
|
||||||
dbIfAuth groupId (deleteWhere [TodolistItemTodolistId ==. todolistId, TodolistItemValue ==. True])
|
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
|
||||||
postSortTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
postSortTodolistItemsR groupId todolistId = do
|
|
||||||
mSession <- lookupSession "sort"
|
|
||||||
case mSession of
|
|
||||||
(Just "value") -> setSession "sort" "id"
|
|
||||||
_ -> setSession "sort" "value"
|
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
|
||||||
|
|
||||||
getGroups :: Key User -> Handler [Entity Group]
|
|
||||||
getGroups userId =
|
|
||||||
let sql = "SELECT ?? FROM \"group\" JOIN group_user gu ON \"group\".id = gu.group_id WHERE gu.user = ?" in
|
|
||||||
runDB $ rawSql sql [toPersistValue userId]
|
|
||||||
|
|
||||||
-- TODO: complete implementation should short circuit if multi user is on but no user exist
|
|
||||||
getUserId :: HandlerFor App (Key User)
|
|
||||||
getUserId = do
|
|
||||||
mName <- lookupHeader "Remote-User"
|
|
||||||
mUser <- case mName of
|
|
||||||
-- TODO: make remote user an argument to make it usable not only with authelia, and maybe do a check for good mesure when nothing is found ?
|
|
||||||
Just name -> runDB $ insertBy $ User (decodeUtf8 name)
|
|
||||||
Nothing -> runDB $ insertBy $ User "single-user"
|
|
||||||
case mUser of
|
|
||||||
Left (Entity userId _) -> return userId
|
|
||||||
Right userId -> return userId
|
|
||||||
|
|
||||||
dbIfAuth :: GroupId -> ReaderT SqlBackend (HandlerFor App) b -> HandlerFor App b
|
|
||||||
dbIfAuth groupId action = do
|
|
||||||
-- TODO: decide if we prefer fast (rawSql) or safe (type safe persist query) after in production latency tests
|
|
||||||
-- TODO: optimize the persist implementation anyway
|
|
||||||
user <- getUserId
|
|
||||||
result <- runDB $ selectFirst [GroupUserUser ==. user, GroupUserGroupId ==. groupId] []
|
|
||||||
if isNothing result then permissionDenied "you are not logged in or you dont have access to this group"
|
|
||||||
else runDB action
|
|
||||||
89
src/Handler/Todolist.hs
Normal file
89
src/Handler/Todolist.hs
Normal file
|
|
@ -0,0 +1,89 @@
|
||||||
|
{-# 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.Todolist where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Text.Read
|
||||||
|
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
||||||
|
postAddTodolistR :: GroupId -> Handler Html
|
||||||
|
postAddTodolistR groupId = do
|
||||||
|
list <- runInputPost $ ireq textField "list"
|
||||||
|
-- TODO: in a newer version, put insertUnique_
|
||||||
|
_ <- dbIfAuth groupId (insertUnique $ Todolist groupId list)
|
||||||
|
redirect $ TodolistR groupId
|
||||||
|
|
||||||
|
-- TODO: move this to a new handler file
|
||||||
|
getTodolistR :: GroupId -> Handler Html
|
||||||
|
getTodolistR groupId = do
|
||||||
|
lists <- dbIfAuth groupId (selectList [TodolistGroupId ==. groupId] [])
|
||||||
|
mToken <- fmap reqToken getRequest
|
||||||
|
defaultLayout $ do
|
||||||
|
let getTitle = todolistTitle . entityVal
|
||||||
|
setTitle "todolist"
|
||||||
|
[whamlet|
|
||||||
|
<a href=@{GroupR}>Home
|
||||||
|
<ul>
|
||||||
|
$forall list <- lists
|
||||||
|
<li>
|
||||||
|
<a href=@{TodolistItemsR groupId (entityKey list)}>#{getTitle list}
|
||||||
|
<form action=@{AddTodolistR groupId} method="post">
|
||||||
|
<input type="text" name="list" placeholder="new list">
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<button type="submit">add
|
||||||
|
<form action=@{AddUserR groupId} method="post">
|
||||||
|
<input type="text" name="user" placeholder="new user">
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<button type="submit">share
|
||||||
|
<a href=@{EditTodolistR groupId}>Edit
|
||||||
|
|]
|
||||||
|
|
||||||
|
getEditTodolistR :: GroupId -> Handler Html
|
||||||
|
getEditTodolistR groupId = do
|
||||||
|
lists <- runDB $
|
||||||
|
selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
|
||||||
|
mToken <- fmap reqToken getRequest
|
||||||
|
defaultLayout $ do
|
||||||
|
let keyToText e = pack $ show $ fromSqlKey $ entityKey e ::Text
|
||||||
|
setTitle "Groups"
|
||||||
|
[whamlet|
|
||||||
|
<form action=@{DeleteTodolistR groupId} method="POST">
|
||||||
|
<ul>
|
||||||
|
$forall list <- lists
|
||||||
|
<li>
|
||||||
|
<input type="checkbox" name="ids" value="#{keyToText list}">
|
||||||
|
<a href="">#{(todolistTitle . entityVal) list}
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<button type=submit>Delete selected
|
||||||
|
<a href=@{TodolistR groupId}>Back
|
||||||
|
|]
|
||||||
|
postDeleteTodolistR :: GroupId -> Handler Html
|
||||||
|
postDeleteTodolistR groupId = do
|
||||||
|
text <- lookupPostParams "ids"
|
||||||
|
let ints = map (read . unpack) text :: [Int64]
|
||||||
|
let ids = map toSqlKey ints :: [TodolistId]
|
||||||
|
dbIfAuth groupId (deleteWhere [TodolistId <-. ids])
|
||||||
|
redirect $ EditTodolistR groupId
|
||||||
|
postEditTodolistR :: GroupId -> Handler Html
|
||||||
|
postEditTodolistR groupId = error "not done yet"
|
||||||
|
|
||||||
|
postAddUserR :: GroupId -> Handler Html
|
||||||
|
postAddUserR groupId= do
|
||||||
|
user <- runInputPost $ ireq textField "user"
|
||||||
|
_ <- dbIfAuth groupId (do
|
||||||
|
mUserId <- getBy $ UniqueName user
|
||||||
|
case mUserId of
|
||||||
|
Nothing -> --handle error
|
||||||
|
redirect $ TodolistR groupId
|
||||||
|
Just userId -> insert $ GroupUser (entityKey userId) groupId
|
||||||
|
)
|
||||||
|
redirect $ TodolistR groupId
|
||||||
127
src/Handler/TodolistItem.hs
Normal file
127
src/Handler/TodolistItem.hs
Normal file
|
|
@ -0,0 +1,127 @@
|
||||||
|
{-# 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.TodolistItem where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import Database.Persist.Sql (rawExecute)
|
||||||
|
|
||||||
|
getTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||||
|
getTodolistItemsR groupId todolistId = do
|
||||||
|
mSortOption <- lookupSession "sort"
|
||||||
|
items <- case mSortOption of
|
||||||
|
(Just "value") -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Desc TodolistItemValue, Asc TodolistItemId])
|
||||||
|
_ -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Asc TodolistItemId])
|
||||||
|
|
||||||
|
mToken <- fmap reqToken getRequest
|
||||||
|
defaultLayout $ do
|
||||||
|
setTitle "items"
|
||||||
|
[whamlet|
|
||||||
|
<a href=@{GroupR}>Home
|
||||||
|
|
||||||
|
<a href=@{TodolistR groupId}>Lists
|
||||||
|
<ul>
|
||||||
|
$forall item <- items
|
||||||
|
<li>
|
||||||
|
<form action=@{CheckTodolistItemR groupId todolistId (entityKey item)} method="POST">
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<button type="submit">#{getText item}
|
||||||
|
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
||||||
|
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
||||||
|
<input type="text" name="item" placeholder="new item">
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<button type="submit">add
|
||||||
|
<form action=@{TrimTodolistItemsR groupId todolistId} method="post">
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<button type="submit">trim
|
||||||
|
<form action=@{SortTodolistItemsR groupId todolistId} method="post">
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<button type="submit">sort
|
||||||
|
<a href=@{EditTodolistItemsR groupId todolistId}>Edit
|
||||||
|
|]
|
||||||
|
|
||||||
|
|
||||||
|
postCheckTodolistItemR :: GroupId -> TodolistId -> TodolistItemId -> Handler Html
|
||||||
|
postCheckTodolistItemR groupId todolistId todolistItemId = do
|
||||||
|
dbIfAuth groupId (rawExecute "UPDATE todolist_item SET value = NOT value WHERE id = ?" [toPersistValue todolistItemId])
|
||||||
|
redirect $ TodolistItemsR groupId todolistId
|
||||||
|
|
||||||
|
|
||||||
|
postAddTodolistItemR :: GroupId -> TodolistId -> Handler Html
|
||||||
|
postAddTodolistItemR groupId todolistId = do
|
||||||
|
item <- runInputPost $ ireq textField "item"
|
||||||
|
_ <- dbIfAuth groupId (insert_ $ TodolistItem todolistId False item)
|
||||||
|
redirect $ TodolistItemsR groupId todolistId
|
||||||
|
|
||||||
|
getEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||||
|
getEditTodolistItemsR groupId todolistId = do
|
||||||
|
items <- dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [])
|
||||||
|
mToken <- fmap reqToken getRequest
|
||||||
|
let text = unlines $ map getText items
|
||||||
|
defaultLayout $ do
|
||||||
|
setTitle "edit"
|
||||||
|
[whamlet|
|
||||||
|
<form action=@{EditTodolistItemsR groupId todolistId} method=POST>
|
||||||
|
<label for="edit text area">Edit todolist
|
||||||
|
<br>
|
||||||
|
<textarea id="edit text area" name=text rows=30 cols=50 placeholder="[x] wake up1 [x] eat [ ] sleep [ ] repeat">#{text}
|
||||||
|
$maybe token <- mToken
|
||||||
|
<input type="hidden" name="_token" value="#{token}">
|
||||||
|
<br>
|
||||||
|
<button type="submit">edit
|
||||||
|
|]
|
||||||
|
postEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||||
|
postEditTodolistItemsR groupId todolistId = do
|
||||||
|
mText <- runInputPost $ iopt textField "text"
|
||||||
|
let xs = case mText of
|
||||||
|
(Just text) -> getItems text todolistId
|
||||||
|
Nothing -> []
|
||||||
|
dbIfAuth groupId (do
|
||||||
|
deleteWhere [TodolistItemTodolistId ==. todolistId]
|
||||||
|
insertMany_ xs)
|
||||||
|
|
||||||
|
redirect $ TodolistItemsR groupId todolistId
|
||||||
|
|
||||||
|
getText :: Entity TodolistItem -> Text
|
||||||
|
getText item =
|
||||||
|
if value then "[x] " <> name
|
||||||
|
else "[ ] " <> name
|
||||||
|
where
|
||||||
|
value = (todolistItemValue . entityVal) item
|
||||||
|
name = (todolistItemName . entityVal) item
|
||||||
|
|
||||||
|
getItems :: Text -> TodolistId -> [TodolistItem]
|
||||||
|
getItems text todolistId = map read (lines text)
|
||||||
|
where read line = do
|
||||||
|
let (d, n) = splitAt 4 line
|
||||||
|
let
|
||||||
|
value = case d of
|
||||||
|
"[x] " -> True
|
||||||
|
"[ ] " -> False
|
||||||
|
_ -> error "Invalid status"
|
||||||
|
name = case n of
|
||||||
|
"" -> error "empty name"
|
||||||
|
something -> filter (/= '\r') something
|
||||||
|
TodolistItem todolistId value name
|
||||||
|
|
||||||
|
postTrimTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||||
|
postTrimTodolistItemsR groupId todolistId = do
|
||||||
|
dbIfAuth groupId (deleteWhere [TodolistItemTodolistId ==. todolistId, TodolistItemValue ==. True])
|
||||||
|
redirect $ TodolistItemsR groupId todolistId
|
||||||
|
postSortTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||||
|
postSortTodolistItemsR groupId todolistId = do
|
||||||
|
mSession <- lookupSession "sort"
|
||||||
|
case mSession of
|
||||||
|
(Just "value") -> setSession "sort" "id"
|
||||||
|
_ -> setSession "sort" "value"
|
||||||
|
redirect $ TodolistItemsR groupId todolistId
|
||||||
Loading…
Add table
Add a link
Reference in a new issue