refactor to make it easier to navigate
This commit is contained in:
parent
ee514454f7
commit
2353d2fdc9
7 changed files with 330 additions and 303 deletions
|
|
@ -44,7 +44,9 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
|
|||
-- Import all relevant handler modules here.
|
||||
-- Don't forget to add new modules to your cabal file!
|
||||
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
|
||||
-- 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/Serve-static-files-from-a-separate-domain
|
||||
-- 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