version 1 done
This commit is contained in:
commit
59e14ce390
47 changed files with 9188 additions and 0 deletions
22
src/Handler/Common.hs
Normal file
22
src/Handler/Common.hs
Normal file
|
|
@ -0,0 +1,22 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- | Common handler functions.
|
||||
module Handler.Common where
|
||||
|
||||
import Data.FileEmbed (embedFile)
|
||||
import Import
|
||||
|
||||
-- These handlers embed files in the executable at compile time to avoid a
|
||||
-- runtime dependency, and for efficiency.
|
||||
|
||||
getFaviconR :: Handler TypedContent
|
||||
getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
|
||||
return $ TypedContent "image/x-icon"
|
||||
$ toContent $(embedFile "config/favicon.ico")
|
||||
|
||||
getRobotsR :: Handler TypedContent
|
||||
getRobotsR = return $ TypedContent typePlain
|
||||
$ toContent $(embedFile "config/robots.txt")
|
||||
41
src/Handler/Home.hs
Normal file
41
src/Handler/Home.hs
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Handler.Home where
|
||||
|
||||
import Import
|
||||
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
|
||||
import Text.Julius (RawJS (..))
|
||||
|
||||
-- Define our data that will be used for creating the form.
|
||||
data FileForm = FileForm
|
||||
{ fileInfo :: FileInfo
|
||||
, fileDescription :: Text
|
||||
}
|
||||
|
||||
-- This is a handler function for the GET request method on the HomeR
|
||||
-- resource pattern. All of your resource patterns are defined in
|
||||
-- config/routes.yesodroutes
|
||||
--
|
||||
-- The majority of the code you will write in Yesod lives in these handler
|
||||
-- functions. You can spread them across multiple files if you are so
|
||||
-- inclined, or create a single monolithic file.
|
||||
|
||||
|
||||
sampleForm :: Form FileForm
|
||||
sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
|
||||
<$> fileAFormReq "Choose a file"
|
||||
<*> areq textField textSettings Nothing
|
||||
-- Add attributes like the placeholder and CSS classes.
|
||||
where textSettings = FieldSettings
|
||||
{ fsLabel = "What's on the file?"
|
||||
, fsTooltip = Nothing
|
||||
, fsId = Nothing
|
||||
, fsName = Nothing
|
||||
, fsAttrs =
|
||||
[ ("class", "form-control")
|
||||
, ("placeholder", "File description")
|
||||
]
|
||||
}
|
||||
249
src/Handler/TodoEntry.hs
Normal file
249
src/Handler/TodoEntry.hs
Normal file
|
|
@ -0,0 +1,249 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
module Handler.TodoEntry where
|
||||
|
||||
import Import
|
||||
import Text.Read
|
||||
import Database.Persist.Sql (rawExecute, fromSqlKey, toSqlKey)
|
||||
-- TODO: move this back to another handler
|
||||
getHomeR :: Handler Html
|
||||
getHomeR = do
|
||||
user <- getUserId
|
||||
groups <- runDB $ do
|
||||
selectList [GroupUserUser ==. user] [Asc GroupUserGroup]
|
||||
mToken <- fmap reqToken getRequest
|
||||
defaultLayout $ do
|
||||
setTitle "Groups"
|
||||
[whamlet|
|
||||
<a href=@{HomeR}>Home
|
||||
<ul>
|
||||
$forall group <- groups
|
||||
<li>
|
||||
<a href=@{TodolistR $ (groupUserGroupId . entityVal) group}>#{(groupUserGroup . 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 g 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
|
||||
<a href=@{EditTodolistR groupId}>Edit
|
||||
|]
|
||||
|
||||
getTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||
getTodolistItemsR groupId todolistId = do
|
||||
items <- dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [])
|
||||
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
|
||||
<a href=@{EditTodolistItemsR groupId todolistId}>Edit list
|
||||
|]
|
||||
|
||||
|
||||
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
|
||||
text <- runInputPost $ ireq textField "text"
|
||||
let xs = getItems text todolistId
|
||||
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
|
||||
groups <- runDB $ do
|
||||
-- TODO: using 404 is just a hack to win time, but next it needs better auth handling
|
||||
userId <- getBy404 $ UniqueName getUser
|
||||
selectList [GroupUserUser ==. entityKey userId] [Asc GroupUserGroup]
|
||||
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="">#{(groupUserGroup . 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)
|
||||
runDB $ deleteWhere [GroupId <-. ids]
|
||||
redirect EditGroupR
|
||||
|
||||
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
|
||||
-- TODO: complete implementation should short circuit if multi user is on but no user exist
|
||||
getUser = "Stuce" :: Text
|
||||
|
||||
getUserId :: Handler (Key User)
|
||||
getUserId = do
|
||||
mUser <- runDB $ getBy $ UniqueName getUser
|
||||
case mUser of
|
||||
Nothing -> runDB $ insert $ User getUser
|
||||
Just u -> return $ entityKey u
|
||||
|
||||
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
|
||||
Loading…
Add table
Add a link
Reference in a new issue