Compare commits
No commits in common. "main" and "r2" have entirely different histories.
25 changed files with 609 additions and 583 deletions
21
README.md
21
README.md
|
|
@ -1,28 +1,25 @@
|
||||||
# sTodo
|
# sTodo
|
||||||
Stuce's simple todo is a web app that let's you self host a simple todolist.
|
Stuce's simple todo is a web app that let's you self host a simple todolist.
|
||||||
The goal is to provide a minimalistic and fast todo list that is self hostable.
|
The goal is to provide a minimalistic and fast todo list that is self hostable.
|
||||||
## Usage
|
|
||||||
- can be used as is for a single user behind a vpn (for ex, wireguard)
|
|
||||||
- can be setup for multi user with a reverse proxy and an authentification provider that supports trusted sso (for ex, nginx + authelia)
|
|
||||||
## Next goals
|
## Next goals
|
||||||
- Make multi user support
|
- Make multi user support
|
||||||
|
- [ ] Get user by trusted header
|
||||||
|
- [ ] Add option to enable single user (usefull for vpn single user easy setup)
|
||||||
|
- [ ] Add menu to add other users to the group
|
||||||
|
- [ ] make the code more readable by renaming/moving the handlers better
|
||||||
- [ ] write a minimal step by step guide to install with nix,
|
- [ ] write a minimal step by step guide to install with nix,
|
||||||
- [ ] add some css to make it look nicer
|
- [ ] add some css to make it look nicer
|
||||||
- [ ] add htmx to make more agreable without making js manadatory
|
- [ ] add htmx to make more agreable without making js manadatory
|
||||||
- [x] make api to allow usage with native app (a way to get every list that has been modified since date $date belonging from the user in a json or similar format)
|
## Version 1.0.0
|
||||||
- [ ] use getRep and provideRep to make text/javascript response as alternatives to html
|
Simple todo list for **single user only** at the moment.
|
||||||
- [ ] document api to help create clients
|
|
||||||
## Version 0.0.3
|
|
||||||
Simple todo list webapp.
|
|
||||||
Features :
|
Features :
|
||||||
- add and delete groups that contain a list of todolists
|
- add and delete (and soon share) groups that contain a list of todolists
|
||||||
- add and delete todolists inside groups
|
- add and delete todolists inside groups
|
||||||
- add todolist items or edit complete list via text for easy manipulation
|
- add todolist items or edit complete list via text for easy manipulation
|
||||||
- api to allow creating native clients with offline capability
|
|
||||||
- possibility to deploy easily via nix module with a flake
|
- possibility to deploy easily via nix module with a flake
|
||||||
- that's it, the goal is to keep it minimal !!!
|
- that's it, the goal is to keep it minimal !!!
|
||||||
# Development
|
|
||||||
## Haskell Setup
|
## Haskell Setup (I sadly don't use nix develop at the moment)
|
||||||
|
|
||||||
1. If you haven't already, [install Stack](https://haskell-lang.org/get-started)
|
1. If you haven't already, [install Stack](https://haskell-lang.org/get-started)
|
||||||
* On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh`
|
* On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh`
|
||||||
|
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
:M^¦ÄO2«I†è𑳉4,pe<70>¿Ôì8Ä·,CI†(q¸¦7/ ÷gGˆuâÍ×¥L'¿(Éœ¡wq1I#ÔpµÌYW»)2L{2—;våÇ_ižËÀ[ÛÈʳ<C38A>ûÕY
|
|
||||||
|
|
@ -8,15 +8,13 @@ TodolistItem
|
||||||
Todolist
|
Todolist
|
||||||
groupId GroupId OnDeleteCascade
|
groupId GroupId OnDeleteCascade
|
||||||
title Text
|
title Text
|
||||||
lastModified UTCTime
|
|
||||||
UniqueListPair groupId title
|
UniqueListPair groupId title
|
||||||
User
|
User
|
||||||
name Text
|
name Text
|
||||||
lastModified UTCTime
|
|
||||||
UniqueName name
|
UniqueName name
|
||||||
Group
|
Group
|
||||||
group Text
|
group Text
|
||||||
lastModified UTCTime
|
|
||||||
GroupUser
|
GroupUser
|
||||||
user UserId
|
user UserId
|
||||||
|
group Text
|
||||||
groupId GroupId OnDeleteCascade
|
groupId GroupId OnDeleteCascade
|
||||||
|
|
@ -6,7 +6,7 @@
|
||||||
/favicon.ico FaviconR GET
|
/favicon.ico FaviconR GET
|
||||||
/robots.txt RobotsR GET
|
/robots.txt RobotsR GET
|
||||||
|
|
||||||
/ GroupR GET
|
/ HomeR GET
|
||||||
/group/#GroupId TodolistR GET
|
/group/#GroupId TodolistR GET
|
||||||
|
|
||||||
/add AddGroupR POST
|
/add AddGroupR POST
|
||||||
|
|
@ -16,14 +16,10 @@
|
||||||
|
|
||||||
/check/group/#GroupId/todolist/#TodolistId/#TodolistItemId CheckTodolistItemR POST
|
/check/group/#GroupId/todolist/#TodolistId/#TodolistItemId CheckTodolistItemR POST
|
||||||
/edit/group/#GroupId/todolist/#TodolistId EditTodolistItemsR GET POST
|
/edit/group/#GroupId/todolist/#TodolistId EditTodolistItemsR GET POST
|
||||||
/sort/group/#GroupId/todolist/#TodolistId SortTodolistItemsR POST
|
|
||||||
/trim/group/#GroupId/todolist/#TodolistId TrimTodolistItemsR POST
|
|
||||||
|
|
||||||
/edit/group/#GroupId EditTodolistR GET POST
|
/edit/group/#GroupId EditTodolistR GET POST
|
||||||
/adduser/group/#GroupId AddUserR POST
|
|
||||||
/edit EditGroupR GET POST
|
/edit EditGroupR GET POST
|
||||||
|
|
||||||
/delete DeleteGroupR POST
|
/delete DeleteGroupR POST
|
||||||
/delete/group/#GroupId DeleteTodolistR POST
|
/delete/group/#GroupId DeleteTodolistR POST
|
||||||
|
|
||||||
/api/#Int ApiR GET
|
|
||||||
|
|
|
||||||
|
|
@ -10,8 +10,8 @@
|
||||||
nixpkgs,
|
nixpkgs,
|
||||||
}: let
|
}: let
|
||||||
tarball = fetchTarball {
|
tarball = fetchTarball {
|
||||||
url = "https://git.stuce.ch/stuce/sTodo/releases/download/r3/r3.tar.gz";
|
url = "https://git.stuce.ch/stuce/sTodo/releases/download/Release1/release1.tar.gz";
|
||||||
sha256 = "1imgbbgbgx2r8qr90mpxlwfy9hcfpdz0sa4nir05jhqx8q1rl0y1";
|
sha256 = "10jyldwmcs5zyz1k8lp3jscn7nhlvn56g0709l5jp91qimw7xiqz";
|
||||||
};
|
};
|
||||||
in {
|
in {
|
||||||
packages.x86_64-linux.sTodo = with nixpkgs.legacyPackages.x86_64-linux;
|
packages.x86_64-linux.sTodo = with nixpkgs.legacyPackages.x86_64-linux;
|
||||||
|
|
@ -19,12 +19,10 @@
|
||||||
pname = "sTodo";
|
pname = "sTodo";
|
||||||
version = "1.0.0";
|
version = "1.0.0";
|
||||||
src = tarball;
|
src = tarball;
|
||||||
buildInputs = [libz gmp libffi];
|
buildInputs = [zlib gmp libffi openssl];
|
||||||
nativeBuildInputs = [openssl];
|
|
||||||
installPhase = ''
|
installPhase = ''
|
||||||
mkdir -p $out/bin
|
mkdir -p $out/bin
|
||||||
cp $src/sTodo $out/bin
|
cp $src/sTodo $out/bin
|
||||||
chmod ugo+x $out/bin/sTodo
|
|
||||||
'';
|
'';
|
||||||
mainProgram = "sTodo";
|
mainProgram = "sTodo";
|
||||||
};
|
};
|
||||||
|
|
|
||||||
|
|
@ -44,10 +44,7 @@ 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.Group
|
import Handler.TodoEntry
|
||||||
import Handler.Todolist
|
|
||||||
import Handler.TodolistItem
|
|
||||||
import Handler.Api
|
|
||||||
|
|
||||||
-- 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
|
||||||
|
|
|
||||||
|
|
@ -1,40 +1,36 @@
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
{-# LANGUAGE ImportQualifiedPost #-}
|
|
||||||
{-# LANGUAGE InstanceSigs #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE InstanceSigs #-}
|
||||||
|
|
||||||
module Foundation where
|
module Foundation where
|
||||||
|
|
||||||
import Control.Monad.Logger (LogSource)
|
|
||||||
import Data.Kind (Type)
|
|
||||||
import Data.Text qualified as Text (intercalate, pack)
|
|
||||||
import Database.Persist.Sql (ConnectionPool, rawSql, runSqlPool)
|
|
||||||
import Import.NoFoundation
|
import Import.NoFoundation
|
||||||
|
import Data.Kind (Type)
|
||||||
|
import Database.Persist.Sql (ConnectionPool, runSqlPool)
|
||||||
import Text.Hamlet (hamletFile)
|
import Text.Hamlet (hamletFile)
|
||||||
import Text.Jasmine (minifym)
|
import Text.Jasmine (minifym)
|
||||||
|
import Control.Monad.Logger (LogSource)
|
||||||
|
|
||||||
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
|
|
||||||
import Yesod.Core.Types (Logger)
|
|
||||||
import Yesod.Core.Unsafe qualified as Unsafe
|
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
|
import Yesod.Core.Types (Logger)
|
||||||
|
import qualified Yesod.Core.Unsafe as Unsafe
|
||||||
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
import qualified Data.Text.Encoding as TE
|
||||||
|
|
||||||
{- | The foundation datatype for your application. This can be a good place to
|
-- | The foundation datatype for your application. This can be a good place to
|
||||||
keep settings and values requiring initialization before your application
|
-- keep settings and values requiring initialization before your application
|
||||||
starts running, such as database connections. Every handler will have
|
-- starts running, such as database connections. Every handler will have
|
||||||
access to the data present here.
|
-- access to the data present here.
|
||||||
-}
|
|
||||||
data App = App
|
data App = App
|
||||||
{ appSettings :: AppSettings
|
{ appSettings :: AppSettings
|
||||||
, appStatic :: Static
|
, appStatic :: Static -- ^ Settings for static file serving.
|
||||||
-- ^ Settings for static file serving.
|
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||||
, appConnPool :: ConnectionPool
|
|
||||||
-- ^ Database connection pool.
|
|
||||||
, appHttpManager :: Manager
|
, appHttpManager :: Manager
|
||||||
, appLogger :: Logger
|
, appLogger :: Logger
|
||||||
}
|
}
|
||||||
|
|
@ -67,10 +63,8 @@ mkYesodData "App" $(parseRoutesFile "config/routes.yesodroutes")
|
||||||
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
|
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
|
||||||
|
|
||||||
-- | A convenient synonym for database access functions.
|
-- | A convenient synonym for database access functions.
|
||||||
type DB a =
|
type DB a = forall (m :: Type -> Type).
|
||||||
forall (m :: Type -> Type).
|
(MonadUnliftIO m) => ReaderT SqlBackend m a
|
||||||
(MonadUnliftIO m) =>
|
|
||||||
ReaderT SqlBackend m a
|
|
||||||
|
|
||||||
-- Please see the documentation for the Yesod typeclass. There are a number
|
-- Please see the documentation for the Yesod typeclass. There are a number
|
||||||
-- of settings which can be configured by overriding methods here.
|
-- of settings which can be configured by overriding methods here.
|
||||||
|
|
@ -83,12 +77,12 @@ instance Yesod App where
|
||||||
Nothing -> getApprootText guessApproot app req
|
Nothing -> getApprootText guessApproot app req
|
||||||
Just root -> root
|
Just root -> root
|
||||||
|
|
||||||
-- -- Store session data on the client in encrypted cookies,
|
-- Store session data on the client in encrypted cookies,
|
||||||
-- -- default session idle timeout is 120 minutes
|
-- default session idle timeout is 120 minutes
|
||||||
-- makeSessionBackend :: App -> IO (Maybe SessionBackend)
|
makeSessionBackend :: App -> IO (Maybe SessionBackend)
|
||||||
-- makeSessionBackend app = Just <$> defaultClientSessionBackend
|
makeSessionBackend app = Just <$> defaultClientSessionBackend
|
||||||
-- 120 -- timeout in minutes
|
120 -- timeout in minutes
|
||||||
-- (appSessionKey $ appSettings app)
|
(appSessionKey $ appSettings app)
|
||||||
|
|
||||||
-- Yesod Middleware allows you to run code before and after each handler function.
|
-- Yesod Middleware allows you to run code before and after each handler function.
|
||||||
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
|
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
|
||||||
|
|
@ -97,15 +91,15 @@ instance Yesod App where
|
||||||
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
|
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
|
||||||
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
||||||
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
|
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
|
||||||
-- yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
|
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
|
||||||
-- yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
||||||
|
|
||||||
defaultLayout :: Widget -> Handler Html
|
defaultLayout :: Widget -> Handler Html
|
||||||
defaultLayout widget = do
|
defaultLayout widget = do
|
||||||
master <- getYesod
|
master <- getYesod
|
||||||
mmsg <- getMessage
|
mmsg <- getMessage
|
||||||
|
|
||||||
-- mcurrentRoute <- getCurrentRoute
|
mcurrentRoute <- getCurrentRoute
|
||||||
|
|
||||||
-- We break up the default layout into two components:
|
-- We break up the default layout into two components:
|
||||||
-- default-layout is the contents of the body tag, and
|
-- default-layout is the contents of the body tag, and
|
||||||
|
|
@ -117,25 +111,24 @@ instance Yesod App where
|
||||||
$(widgetFile "default-layout")
|
$(widgetFile "default-layout")
|
||||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||||
|
|
||||||
-- isAuthorized
|
isAuthorized
|
||||||
-- :: Route App -- ^ The route the user is visiting.
|
:: Route App -- ^ The route the user is visiting.
|
||||||
-- -> Bool -- ^ Whether or not this is a "write" request.
|
-> Bool -- ^ Whether or not this is a "write" request.
|
||||||
-- -> Handler AuthResult
|
-> Handler AuthResult
|
||||||
-- -- Routes not requiring authentication.
|
-- Routes not requiring authentication.
|
||||||
-- isAuthorized _ _ = return Authorized
|
-- TODO: check this bullshit if need to change it or not (prolly authelia problem)
|
||||||
|
isAuthorized _ _ = return Authorized
|
||||||
|
|
||||||
|
|
||||||
-- This function creates static content files in the static folder
|
-- This function creates static content files in the static folder
|
||||||
-- and names them based on a hash of their content. This allows
|
-- and names them based on a hash of their content. This allows
|
||||||
-- expiration dates to be set far in the future without worry of
|
-- expiration dates to be set far in the future without worry of
|
||||||
-- users receiving stale content.
|
-- users receiving stale content.
|
||||||
addStaticContent ::
|
addStaticContent
|
||||||
Text ->
|
:: Text -- ^ The file extension
|
||||||
-- \^ The file extension
|
-> Text -- ^ The MIME content type
|
||||||
Text ->
|
-> LByteString -- ^ The contents of the file
|
||||||
-- \^ The MIME content type
|
-> Handler (Maybe (Either Text (Route App, [(Text, Text)])))
|
||||||
LByteString ->
|
|
||||||
-- \^ The contents of the file
|
|
||||||
Handler (Maybe (Either Text (Route App, [(Text, Text)])))
|
|
||||||
addStaticContent ext mime content = do
|
addStaticContent ext mime content = do
|
||||||
master <- getYesod
|
master <- getYesod
|
||||||
let staticDir = appStaticDir $ appSettings master
|
let staticDir = appStaticDir $ appSettings master
|
||||||
|
|
@ -155,12 +148,10 @@ instance Yesod App where
|
||||||
-- in development, and warnings and errors in production.
|
-- in development, and warnings and errors in production.
|
||||||
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
|
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
|
||||||
shouldLogIO app _source level =
|
shouldLogIO app _source level =
|
||||||
return
|
return $
|
||||||
$ appShouldLogAll (appSettings app)
|
appShouldLogAll (appSettings app)
|
||||||
|| level
|
|| level == LevelWarn
|
||||||
== LevelWarn
|
|| level == LevelError
|
||||||
|| level
|
|
||||||
== LevelError
|
|
||||||
|
|
||||||
makeLogger :: App -> IO Logger
|
makeLogger :: App -> IO Logger
|
||||||
makeLogger = return . appLogger
|
makeLogger = return . appLogger
|
||||||
|
|
@ -200,50 +191,3 @@ 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, to enforce policy safely
|
|
||||||
getUserId :: HandlerFor App (Key User)
|
|
||||||
getUserId = do
|
|
||||||
mName <- lookupHeader "Remote-User"
|
|
||||||
currentTime <- liftIO getCurrentTime
|
|
||||||
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) currentTime
|
|
||||||
Nothing -> runDB $ insertBy $ User "single-user" currentTime
|
|
||||||
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
|
|
||||||
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
|
|
||||||
|
|
||||||
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]
|
|
||||||
|
|
||||||
todolistItemToCSV :: Entity TodolistItem -> Text
|
|
||||||
todolistItemToCSV item = "i," <> fieldToText item
|
|
||||||
todolistToCSV :: Entity Todolist -> Text
|
|
||||||
todolistToCSV list = "l," <> fieldToText list
|
|
||||||
groupToCSV :: Entity Group -> Text
|
|
||||||
groupToCSV group = "g," <> fieldToText group
|
|
||||||
userToCSV :: Entity User -> Text
|
|
||||||
userToCSV user = "u," <> fieldToText user
|
|
||||||
|
|
||||||
-- TODO: error management ? (maybe use Either Text Text and then propagate left to handler and send error ?)
|
|
||||||
fieldToText :: (PersistEntity record) => Entity record -> Text
|
|
||||||
fieldToText field = Text.intercalate "," (map persistValueToText $ entityValues field)
|
|
||||||
|
|
||||||
persistValueToText :: PersistValue -> Text
|
|
||||||
persistValueToText (PersistText s) = s
|
|
||||||
persistValueToText (PersistInt64 i) = Text.pack $ show i
|
|
||||||
persistValueToText (PersistUTCTime d) = Text.pack $ show $ floor (utcTimeToPOSIXSeconds d)
|
|
||||||
persistValueToText (PersistBool b) = if b then "T" else "F"
|
|
||||||
persistValueToText _ = error "Wrong input type"
|
|
||||||
|
|
|
||||||
|
|
@ -1,33 +0,0 @@
|
||||||
{-# LANGUAGE ImportQualifiedPost #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
|
|
||||||
module Handler.Api where
|
|
||||||
|
|
||||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
|
||||||
import Database.Persist.Sql (rawSql)
|
|
||||||
import Import
|
|
||||||
|
|
||||||
getApiR :: Int -> Handler TypedContent
|
|
||||||
getApiR time = do
|
|
||||||
-- TODO: use only one runDB (or use joins ?)
|
|
||||||
userId <- getUserId
|
|
||||||
let utcTime = posixSecondsToUTCTime (fromIntegral time)
|
|
||||||
-- condition : parent user or group changed
|
|
||||||
let sqlUpdatedGroups = "select ?? from \"group\" join group_user gu on \"group\".id = gu.group_id where gu.user = ? where \"group\".last_modified > ? or user.last_modified > ?;"
|
|
||||||
-- condition : parent group or list changed
|
|
||||||
let sqlUpdatedLists = "select ?? from todolist join group_user on todolist.group_id = group_user.group_id and group_user.user = ? join \"group\" as g on g.id = todolist.id where list.last_modified > ? or g.last_modified > ?;"
|
|
||||||
-- condition : parent list changed
|
|
||||||
let sqlUpdatedItems = "select ?? from todolist where todolist.last_modified > ? join group_user on todolist.group_id = group_user.group_id and group_user.user = ? join todolist_item on todolist_item.todolist_id = todolist.id;"
|
|
||||||
runDB $ do
|
|
||||||
user <- selectList [UserId ==. userId, UserLastModified >. utcTime] []
|
|
||||||
groups <- rawSql sqlUpdatedGroups [toPersistValue userId, toPersistValue utcTime, toPersistValue utcTime]
|
|
||||||
lists <- rawSql sqlUpdatedLists [toPersistValue userId, toPersistValue utcTime, toPersistValue utcTime]
|
|
||||||
items <- rawSql sqlUpdatedItems [toPersistValue utcTime, toPersistValue userId]
|
|
||||||
let t =
|
|
||||||
unlines
|
|
||||||
$ map userToCSV user
|
|
||||||
<> map groupToCSV groups
|
|
||||||
<> map todolistToCSV lists
|
|
||||||
<> map todolistItemToCSV items
|
|
||||||
return $ TypedContent typePlain $ toContent t
|
|
||||||
|
|
@ -1,73 +0,0 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
|
||||||
|
|
||||||
module Handler.Group where
|
|
||||||
|
|
||||||
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
|
||||||
import Import
|
|
||||||
import Text.Read
|
|
||||||
|
|
||||||
getGroupR :: Handler TypedContent
|
|
||||||
getGroupR = do
|
|
||||||
userId <- getUserId
|
|
||||||
groups <- getGroups userId
|
|
||||||
selectRep $ do
|
|
||||||
provideRep
|
|
||||||
$ defaultLayout
|
|
||||||
$ do
|
|
||||||
setTitle "Groups"
|
|
||||||
$(widgetFile "group")
|
|
||||||
provideRep $ return $ unlines $ map groupToCSV groups
|
|
||||||
|
|
||||||
postAddGroupR :: Handler TypedContent
|
|
||||||
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 TypedContent
|
|
||||||
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]
|
|
||||||
userId <- getUserId
|
|
||||||
currentTime <- liftIO getCurrentTime
|
|
||||||
-- TODO: test this and maybe change it to sql to be more efficient ?
|
|
||||||
when (ids /= [])
|
|
||||||
$ runDB
|
|
||||||
$ do
|
|
||||||
update userId [UserLastModified =. currentTime]
|
|
||||||
deleteWhere [GroupUserGroupId <-. ids, GroupUserUser ==. userId]
|
|
||||||
nonOrphans <- selectList [GroupUserGroupId <-. ids] []
|
|
||||||
let nonOrphansIds = map (groupUserGroupId . entityVal) nonOrphans
|
|
||||||
deleteWhere [GroupId <-. ids, GroupId /<-. nonOrphansIds]
|
|
||||||
redirect EditGroupR
|
|
||||||
263
src/Handler/TodoEntry.hs
Normal file
263
src/Handler/TodoEntry.hs
Normal file
|
|
@ -0,0 +1,263 @@
|
||||||
|
{-# 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)
|
||||||
|
-- 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
|
||||||
|
userId <- getUserId
|
||||||
|
groups <- runDB $ do
|
||||||
|
selectList [GroupUserUser ==. 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
|
||||||
|
|
||||||
|
|
||||||
|
-- getUserId :: Handler (Key User)
|
||||||
|
-- getUserId = do
|
||||||
|
-- mUser <- runDB $ getBy $ UniqueName "Stuce"
|
||||||
|
-- case mUser of
|
||||||
|
-- Nothing -> runDB $ insert $ User "Stuce"
|
||||||
|
-- Just u -> return $ entityKey u
|
||||||
|
|
||||||
|
-- TODO: use yesodAuth and clean this mess
|
||||||
|
getUserId :: Handler (Key User)
|
||||||
|
getUserId = do
|
||||||
|
mName <- lookupHeader "Remote-User"
|
||||||
|
case mName of
|
||||||
|
-- TODO: if this temporary solution stays, we need here a way to use authDummy somehow in developpement
|
||||||
|
Nothing -> permissionDenied "no trusted header found !"
|
||||||
|
Just name -> do
|
||||||
|
mUser <- runDB $ getBy $ UniqueName (decodeUtf8 name)
|
||||||
|
case mUser of
|
||||||
|
Nothing -> runDB $ insert $ User (decodeUtf8 name)
|
||||||
|
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
|
||||||
|
|
@ -1,78 +0,0 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
|
||||||
|
|
||||||
{-# HLINT ignore "Replace case with fromMaybe" #-}
|
|
||||||
module Handler.Todolist where
|
|
||||||
|
|
||||||
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
|
||||||
import Import
|
|
||||||
import Text.Read
|
|
||||||
|
|
||||||
postAddTodolistR :: GroupId -> Handler Html
|
|
||||||
postAddTodolistR groupId = do
|
|
||||||
list <- runInputPost $ ireq textField "list"
|
|
||||||
-- TODO: in a newer version, put insertUnique_
|
|
||||||
currentTime <- liftIO getCurrentTime
|
|
||||||
_ <- dbIfAuth groupId (insertUnique $ Todolist groupId list currentTime)
|
|
||||||
redirect $ TodolistR groupId
|
|
||||||
|
|
||||||
getTodolistR :: GroupId -> Handler TypedContent
|
|
||||||
getTodolistR groupId = do
|
|
||||||
lists <- dbIfAuth groupId (selectList [TodolistGroupId ==. groupId] [])
|
|
||||||
selectRep $ do
|
|
||||||
provideRep
|
|
||||||
$ defaultLayout
|
|
||||||
$ do
|
|
||||||
let getTitle = todolistTitle . entityVal
|
|
||||||
setTitle "todolist"
|
|
||||||
$(widgetFile "todolist")
|
|
||||||
provideRep $ return $ unlines $ map todolistToCSV lists
|
|
||||||
|
|
||||||
getEditTodolistR :: GroupId -> Handler Html
|
|
||||||
getEditTodolistR groupId = do
|
|
||||||
lists <-
|
|
||||||
runDB
|
|
||||||
$ selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
|
|
||||||
defaultLayout $ do
|
|
||||||
let keyToText e = pack $ show $ fromSqlKey $ entityKey e :: Text
|
|
||||||
setTitle "Groups"
|
|
||||||
$(widgetFile "edit-todolist")
|
|
||||||
|
|
||||||
postDeleteTodolistR :: GroupId -> Handler Html
|
|
||||||
postDeleteTodolistR groupId = do
|
|
||||||
text <- lookupPostParams "ids"
|
|
||||||
currentTime <- liftIO getCurrentTime
|
|
||||||
let ints = map (read . unpack) text :: [Int64]
|
|
||||||
let ids = map toSqlKey ints :: [TodolistId]
|
|
||||||
dbIfAuth
|
|
||||||
groupId
|
|
||||||
( do
|
|
||||||
deleteWhere [TodolistId <-. ids]
|
|
||||||
update groupId [GroupLastModified =. currentTime]
|
|
||||||
)
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -1,121 +0,0 @@
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
|
||||||
|
|
||||||
{-# HLINT ignore "Replace case with fromMaybe" #-}
|
|
||||||
module Handler.TodolistItem where
|
|
||||||
|
|
||||||
import Database.Persist.Sql (rawExecute)
|
|
||||||
import Import
|
|
||||||
|
|
||||||
getTodolistItemsR :: GroupId -> TodolistId -> Handler TypedContent
|
|
||||||
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])
|
|
||||||
|
|
||||||
selectRep $ do
|
|
||||||
provideRep
|
|
||||||
$ defaultLayout
|
|
||||||
$ do
|
|
||||||
setTitle "items"
|
|
||||||
$(widgetFile "todolist-items")
|
|
||||||
provideRep $ return $ unlines $ map todolistItemToCSV items
|
|
||||||
|
|
||||||
postCheckTodolistItemR :: GroupId -> TodolistId -> TodolistItemId -> Handler Html
|
|
||||||
postCheckTodolistItemR groupId todolistId todolistItemId = do
|
|
||||||
currentTime <- liftIO getCurrentTime
|
|
||||||
dbIfAuth
|
|
||||||
groupId
|
|
||||||
( do
|
|
||||||
rawExecute "UPDATE todolist_item SET value = NOT value WHERE id = ?" [toPersistValue todolistItemId]
|
|
||||||
update todolistId [TodolistLastModified =. currentTime]
|
|
||||||
)
|
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
|
||||||
|
|
||||||
postAddTodolistItemR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
postAddTodolistItemR groupId todolistId = do
|
|
||||||
currentTime <- liftIO getCurrentTime
|
|
||||||
item <- runInputPost $ ireq textField "item"
|
|
||||||
_ <-
|
|
||||||
dbIfAuth
|
|
||||||
groupId
|
|
||||||
( do
|
|
||||||
insert_ $ TodolistItem todolistId False item
|
|
||||||
update todolistId [TodolistLastModified =. currentTime]
|
|
||||||
)
|
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
|
||||||
|
|
||||||
getEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
getEditTodolistItemsR groupId todolistId = do
|
|
||||||
items <- dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [])
|
|
||||||
let text = unlines $ map getText items
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitle "edit"
|
|
||||||
$(widgetFile "edit-todolist-items")
|
|
||||||
|
|
||||||
postEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
postEditTodolistItemsR groupId todolistId = do
|
|
||||||
currentTime <- liftIO getCurrentTime
|
|
||||||
mText <- runInputPost $ iopt textField "text"
|
|
||||||
let xs = case mText of
|
|
||||||
(Just text) -> getItems text todolistId
|
|
||||||
Nothing -> [] -- Case statement used to let delete all without error TODO: check if can use flatmap instead ?
|
|
||||||
dbIfAuth
|
|
||||||
groupId
|
|
||||||
( do
|
|
||||||
deleteWhere [TodolistItemTodolistId ==. todolistId]
|
|
||||||
insertMany_ xs
|
|
||||||
update todolistId [TodolistLastModified =. currentTime]
|
|
||||||
)
|
|
||||||
|
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
|
||||||
|
|
||||||
postTrimTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
|
||||||
postTrimTodolistItemsR groupId todolistId = do
|
|
||||||
currentTime <- liftIO getCurrentTime
|
|
||||||
dbIfAuth
|
|
||||||
groupId
|
|
||||||
( do
|
|
||||||
deleteWhere [TodolistItemTodolistId ==. todolistId, TodolistItemValue ==. True]
|
|
||||||
update todolistId [TodolistLastModified =. currentTime]
|
|
||||||
)
|
|
||||||
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
|
|
||||||
|
|
||||||
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
|
|
||||||
|
|
@ -49,7 +49,7 @@ packages:
|
||||||
# extra-package-dbs: []
|
# extra-package-dbs: []
|
||||||
|
|
||||||
# Control whether we use the GHC we find on the path
|
# Control whether we use the GHC we find on the path
|
||||||
system-ghc: true
|
# system-ghc: true
|
||||||
#
|
#
|
||||||
# Require a specific version of Stack, using version ranges
|
# Require a specific version of Stack, using version ranges
|
||||||
# require-stack-version: -any # Default
|
# require-stack-version: -any # Default
|
||||||
|
|
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
# This file was autogenerated by Stack.
|
# This file was autogenerated by Stack.
|
||||||
# You should not edit this file by hand.
|
# You should not edit this file by hand.
|
||||||
# For more information, please see the documentation at:
|
# For more information, please see the documentation at:
|
||||||
# https://docs.haskellstack.org/en/stable/lock_files
|
# https://docs.haskellstack.org/en/stable/topics/lock_files
|
||||||
|
|
||||||
packages: []
|
packages: []
|
||||||
snapshots:
|
snapshots:
|
||||||
|
|
|
||||||
|
|
@ -2,6 +2,7 @@
|
||||||
<div .container>
|
<div .container>
|
||||||
$maybe msg <- mmsg
|
$maybe msg <- mmsg
|
||||||
<div>#{msg}
|
<div>#{msg}
|
||||||
|
|
||||||
^{widget}
|
^{widget}
|
||||||
|
|
||||||
<!-- Footer -->
|
<!-- Footer -->
|
||||||
|
|
|
||||||
|
|
@ -1,8 +0,0 @@
|
||||||
<form action=@{DeleteGroupR} method="POST">
|
|
||||||
<ul>
|
|
||||||
$forall group <- groups
|
|
||||||
<li>
|
|
||||||
<input type="checkbox" name="ids" value="#{a group}">
|
|
||||||
<a href="">#{(groupGroup . entityVal) group}
|
|
||||||
<button type=submit>Delete selected
|
|
||||||
<a href=@{GroupR}>Back
|
|
||||||
|
|
@ -1,6 +0,0 @@
|
||||||
<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}
|
|
||||||
<br>
|
|
||||||
<button type="submit">edit
|
|
||||||
|
|
@ -1,8 +0,0 @@
|
||||||
<form action=@{DeleteTodolistR groupId} method="POST">
|
|
||||||
<ul>
|
|
||||||
$forall list <- lists
|
|
||||||
<li>
|
|
||||||
<input type="checkbox" name="ids" value="#{keyToText list}">
|
|
||||||
<a href="">#{(todolistTitle . entityVal) list}
|
|
||||||
<button type=submit>Delete selected
|
|
||||||
<a href=@{TodolistR groupId}>Back
|
|
||||||
|
|
@ -1,9 +0,0 @@
|
||||||
<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">
|
|
||||||
<button type="submit">add
|
|
||||||
<a href=@{EditGroupR}>Edit
|
|
||||||
141
templates/homepage.hamlet
Normal file
141
templates/homepage.hamlet
Normal file
|
|
@ -0,0 +1,141 @@
|
||||||
|
<div .masthead>
|
||||||
|
<div .container>
|
||||||
|
<div .row>
|
||||||
|
<h1 .header>
|
||||||
|
Yesod—a modern framework for blazing fast websites
|
||||||
|
<h2>
|
||||||
|
Fast, stable & spiced with great community
|
||||||
|
<a href="http://www.yesodweb.com/book/" .btn.btn-info.btn-lg>
|
||||||
|
Read the Book
|
||||||
|
|
||||||
|
<div .container>
|
||||||
|
<!-- Starting
|
||||||
|
================================================== -->
|
||||||
|
<div .bs-docs-section>
|
||||||
|
<div .row>
|
||||||
|
<div .col-lg-12>
|
||||||
|
<div .page-header>
|
||||||
|
<h1 #start>Starting
|
||||||
|
|
||||||
|
<p>
|
||||||
|
Now that you have a working project you should use the
|
||||||
|
<a href=http://www.yesodweb.com/book/>Yesod book</a> to learn more.
|
||||||
|
<p>
|
||||||
|
You can also use this scaffolded site to explore some concepts, and best practices.
|
||||||
|
|
||||||
|
<ul .list-group>
|
||||||
|
|
||||||
|
<li .list-group-item>
|
||||||
|
This page was generated by the <tt>#{handlerName}</tt> handler in
|
||||||
|
<tt>Handler/Home.hs</tt>.
|
||||||
|
|
||||||
|
<li .list-group-item>
|
||||||
|
The <tt>#{handlerName}</tt> handler is set to generate your
|
||||||
|
site's home screen in the Routes file
|
||||||
|
<tt>config/routes.yesodroutes
|
||||||
|
|
||||||
|
<li .list-group-item>
|
||||||
|
We can link to other handlers, like the <a href="@{ProfileR}">Profile</a>.
|
||||||
|
Try it out as an anonymous user and see the access denied.
|
||||||
|
Then, try to <a href="@{AuthR LoginR}">login</a> with the dummy authentication added
|
||||||
|
while in development.
|
||||||
|
|
||||||
|
<li .list-group-item>
|
||||||
|
The HTML you are seeing now is actually composed by a number of <em>widgets</em>, #
|
||||||
|
most of them are brought together by the <tt>defaultLayout</tt> function which #
|
||||||
|
is defined in the <tt>Foundation.hs</tt> module, and used by <tt>#{handlerName}</tt>. #
|
||||||
|
All the files for templates and widgets are in <tt>templates</tt>.
|
||||||
|
|
||||||
|
<li .list-group-item>
|
||||||
|
A Widget's Html, Css and Javascript are separated in three files with the
|
||||||
|
<tt>.hamlet</tt>, <tt>.lucius</tt> and <tt>.julius</tt> extensions.
|
||||||
|
|
||||||
|
<li .list-group-item ##{aDomId}>
|
||||||
|
If you had javascript enabled then you wouldn't be seeing this.
|
||||||
|
|
||||||
|
<hr>
|
||||||
|
|
||||||
|
<!-- Forms
|
||||||
|
================================================== -->
|
||||||
|
<div .bs-docs-section>
|
||||||
|
<div .row>
|
||||||
|
<div .col-lg-12>
|
||||||
|
<div .page-header>
|
||||||
|
<h1 #forms>Forms
|
||||||
|
|
||||||
|
<p>
|
||||||
|
This is an example of a form. Read the
|
||||||
|
<a href="http://www.yesodweb.com/book/forms">Forms chapter</a> #
|
||||||
|
in the yesod book to learn more about them.
|
||||||
|
|
||||||
|
<div .row>
|
||||||
|
<div .col-lg-6>
|
||||||
|
<div .bs-callout bs-callout-info well>
|
||||||
|
<form .form-horizontal method=post action=@{HomeR}#forms enctype=#{formEnctype}>
|
||||||
|
^{formWidget}
|
||||||
|
|
||||||
|
<button .btn.btn-primary type="submit">
|
||||||
|
Upload it!
|
||||||
|
|
||||||
|
|
||||||
|
<div .col-lg-4.col-lg-offset-1>
|
||||||
|
<div .bs-callout.bs-callout-info.upload-response>
|
||||||
|
|
||||||
|
$maybe (FileForm info con) <- submission
|
||||||
|
Your file type is <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em>
|
||||||
|
|
||||||
|
$nothing
|
||||||
|
File upload result will be here...
|
||||||
|
|
||||||
|
|
||||||
|
<hr>
|
||||||
|
|
||||||
|
<!-- JSON
|
||||||
|
================================================== -->
|
||||||
|
<div .bs-docs-section>
|
||||||
|
<div .row>
|
||||||
|
<div .col-lg-12>
|
||||||
|
<div .page-header>
|
||||||
|
<h1 #json>JSON
|
||||||
|
|
||||||
|
<p>
|
||||||
|
Yesod has JSON support baked-in.
|
||||||
|
The form below makes an AJAX request with Javascript,
|
||||||
|
then updates the page with your submission.
|
||||||
|
(see <tt>Handler/Comment.hs</tt>, <tt>templates/homepage.julius</tt>,
|
||||||
|
and <tt>Handler/Home.hs</tt> for the implementation).
|
||||||
|
|
||||||
|
<div .row>
|
||||||
|
<div .col-lg-6>
|
||||||
|
<div .bs-callout.bs-callout-info.well>
|
||||||
|
<form .form-horizontal ##{commentFormId}>
|
||||||
|
<div .field>
|
||||||
|
<textarea rows="2" ##{commentTextareaId} placeholder="Your comment here..." required></textarea>
|
||||||
|
|
||||||
|
<button .btn.btn-primary type=submit>
|
||||||
|
Create comment
|
||||||
|
|
||||||
|
<div .col-lg-4.col-lg-offset-1>
|
||||||
|
<div .bs-callout.bs-callout-info>
|
||||||
|
<small>
|
||||||
|
Your comments will appear here. You can also open the
|
||||||
|
console log to see the raw response from the server.
|
||||||
|
<ul ##{commentListId}>
|
||||||
|
$forall comment <- allComments
|
||||||
|
<li>#{commentMessage $ entityVal comment}
|
||||||
|
|
||||||
|
<hr>
|
||||||
|
|
||||||
|
<!-- Testing
|
||||||
|
================================================== -->
|
||||||
|
<div .bs-docs-section>
|
||||||
|
<div .row>
|
||||||
|
<div .col-lg-12>
|
||||||
|
<div .page-header>
|
||||||
|
<h1 #test>Testing
|
||||||
|
|
||||||
|
<p>
|
||||||
|
And last but not least, Testing. In <tt>test/Spec.hs</tt> you will find a #
|
||||||
|
test suite that performs tests on this page.
|
||||||
|
<p>
|
||||||
|
You can run your tests by doing: <code>stack test</code>
|
||||||
34
templates/homepage.julius
Normal file
34
templates/homepage.julius
Normal file
|
|
@ -0,0 +1,34 @@
|
||||||
|
document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget.";
|
||||||
|
|
||||||
|
$(function() {
|
||||||
|
$("##{rawJS commentFormId}").submit(function(event) {
|
||||||
|
event.preventDefault();
|
||||||
|
|
||||||
|
var message = $("##{rawJS commentTextareaId}").val();
|
||||||
|
// (Browsers that enforce the "required" attribute on the textarea won't see this alert)
|
||||||
|
if (!message) {
|
||||||
|
alert("Please fill out the comment form first.");
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
|
// Make an AJAX request to the server to create a new comment
|
||||||
|
$.ajax({
|
||||||
|
url: '@{CommentR}',
|
||||||
|
type: 'POST',
|
||||||
|
contentType: "application/json",
|
||||||
|
data: JSON.stringify({
|
||||||
|
message: message,
|
||||||
|
}),
|
||||||
|
success: function (data) {
|
||||||
|
var newNode = $("<li></li>");
|
||||||
|
newNode.text(data.message);
|
||||||
|
console.log(data);
|
||||||
|
$("##{rawJS commentListId}").append(newNode);
|
||||||
|
},
|
||||||
|
error: function (data) {
|
||||||
|
console.log("Error creating comment: " + data);
|
||||||
|
},
|
||||||
|
});
|
||||||
|
|
||||||
|
});
|
||||||
|
});
|
||||||
13
templates/homepage.lucius
Normal file
13
templates/homepage.lucius
Normal file
|
|
@ -0,0 +1,13 @@
|
||||||
|
h2##{aDomId} {
|
||||||
|
color: #990
|
||||||
|
}
|
||||||
|
|
||||||
|
li {
|
||||||
|
line-height: 2em;
|
||||||
|
font-size: 16px
|
||||||
|
}
|
||||||
|
|
||||||
|
##{commentTextareaId} {
|
||||||
|
width: 400px;
|
||||||
|
height: 100px;
|
||||||
|
}
|
||||||
10
templates/profile.hamlet
Normal file
10
templates/profile.hamlet
Normal file
|
|
@ -0,0 +1,10 @@
|
||||||
|
<div .ui.container>
|
||||||
|
|
||||||
|
<h1>
|
||||||
|
Access granted!
|
||||||
|
|
||||||
|
<p>
|
||||||
|
This page is protected and access is allowed only for authenticated users.
|
||||||
|
|
||||||
|
<p>
|
||||||
|
Your data is protected with us <strong><span class="username">#{userIdent user}</span></strong>!
|
||||||
|
|
@ -1,17 +0,0 @@
|
||||||
<a href=@{GroupR}>Home
|
|
||||||
|
|
||||||
<a href=@{TodolistR groupId}>Lists
|
|
||||||
<ul>
|
|
||||||
$forall item <- items
|
|
||||||
<li>
|
|
||||||
<form action=@{CheckTodolistItemR groupId todolistId (entityKey item)} method="POST">
|
|
||||||
<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">
|
|
||||||
<button type="submit">add
|
|
||||||
<form action=@{TrimTodolistItemsR groupId todolistId} method="post">
|
|
||||||
<button type="submit">trim
|
|
||||||
<form action=@{SortTodolistItemsR groupId todolistId} method="post">
|
|
||||||
<button type="submit">sort
|
|
||||||
<a href=@{EditTodolistItemsR groupId todolistId}>Edit
|
|
||||||
|
|
@ -1,12 +0,0 @@
|
||||||
<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">
|
|
||||||
<button type="submit">add
|
|
||||||
<form action=@{AddUserR groupId} method="post">
|
|
||||||
<input type="text" name="user" placeholder="new user">
|
|
||||||
<button type="submit">share
|
|
||||||
<a href=@{EditTodolistR groupId}>Edit
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue