Compare commits
2 commits
c9b7bdd84b
...
2ce5997c93
| Author | SHA1 | Date | |
|---|---|---|---|
| 2ce5997c93 | |||
| c4b57d7a29 |
20 changed files with 440 additions and 568 deletions
|
|
@ -10,16 +10,18 @@ The goal is to provide a minimalistic and fast todo list that is self hostable.
|
||||||
- [ ] 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)
|
- [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)
|
||||||
|
- [ ] use getRep and provideRep to make text/javascript response as alternatives to html
|
||||||
- [ ] document api to help create clients
|
- [ ] document api to help create clients
|
||||||
## Version 0.0.3
|
## Version 0.0.3
|
||||||
Simple todo list webapp.
|
Simple todo list webapp.
|
||||||
Features :
|
Features :
|
||||||
- add and delete (and soon share) groups that contain a list of todolists
|
- add and delete 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
|
||||||
|
|
||||||
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)
|
||||||
|
|
|
||||||
|
|
@ -10,9 +10,9 @@ Todolist
|
||||||
title Text
|
title Text
|
||||||
lastModified UTCTime
|
lastModified UTCTime
|
||||||
UniqueListPair groupId title
|
UniqueListPair groupId title
|
||||||
deriving Show
|
|
||||||
User
|
User
|
||||||
name Text
|
name Text
|
||||||
|
lastModified UTCTime
|
||||||
UniqueName name
|
UniqueName name
|
||||||
Group
|
Group
|
||||||
group Text
|
group Text
|
||||||
|
|
|
||||||
|
|
@ -1,47 +1,51 @@
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE InstanceSigs #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
{-# LANGUAGE ExplicitForAll #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
|
||||||
{-# LANGUAGE InstanceSigs #-}
|
|
||||||
|
|
||||||
module Foundation where
|
module Foundation where
|
||||||
|
|
||||||
import Import.NoFoundation
|
|
||||||
import Data.Kind (Type)
|
|
||||||
import Database.Persist.Sql (ConnectionPool, runSqlPool, rawSql)
|
|
||||||
import Text.Hamlet (hamletFile)
|
|
||||||
import Text.Jasmine (minifym)
|
|
||||||
import Control.Monad.Logger (LogSource)
|
import Control.Monad.Logger (LogSource)
|
||||||
|
import Data.Kind (Type)
|
||||||
|
import Database.Persist.Sql (ConnectionPool, rawSql, runSqlPool)
|
||||||
|
import Import.NoFoundation
|
||||||
|
import Text.Hamlet (hamletFile)
|
||||||
|
import Text.Jasmine (minifym)
|
||||||
|
|
||||||
import Yesod.Default.Util (addStaticContentExternal)
|
import Yesod.Core.Types (Logger)
|
||||||
import Yesod.Core.Types (Logger)
|
import Yesod.Core.Unsafe qualified as Unsafe
|
||||||
import qualified Yesod.Core.Unsafe as Unsafe
|
import Yesod.Default.Util (addStaticContentExternal)
|
||||||
|
|
||||||
-- | 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 -- ^ Settings for static file serving.
|
, appStatic :: Static
|
||||||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
-- ^ Settings for static file serving.
|
||||||
, appHttpManager :: Manager
|
, appConnPool :: ConnectionPool
|
||||||
, appLogger :: Logger
|
-- ^ Database connection pool.
|
||||||
}
|
, appHttpManager :: Manager
|
||||||
|
, appLogger :: Logger
|
||||||
|
}
|
||||||
|
|
||||||
data MenuItem = MenuItem
|
data MenuItem = MenuItem
|
||||||
{ menuItemLabel :: Text
|
{ menuItemLabel :: Text
|
||||||
, menuItemRoute :: Route App
|
, menuItemRoute :: Route App
|
||||||
, menuItemAccessCallback :: Bool
|
, menuItemAccessCallback :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
data MenuTypes
|
data MenuTypes
|
||||||
= NavbarLeft MenuItem
|
= NavbarLeft MenuItem
|
||||||
| NavbarRight MenuItem
|
| NavbarRight MenuItem
|
||||||
|
|
||||||
-- This is where we define all of the routes in our application. For a full
|
-- This is where we define all of the routes in our application. For a full
|
||||||
-- explanation of the syntax, please see:
|
-- explanation of the syntax, please see:
|
||||||
|
|
@ -61,122 +65,128 @@ 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 = forall (m :: Type -> Type).
|
type DB a =
|
||||||
(MonadUnliftIO m) => ReaderT SqlBackend m a
|
forall (m :: Type -> Type).
|
||||||
|
(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.
|
||||||
instance Yesod App where
|
instance Yesod App where
|
||||||
-- Controls the base of generated URLs. For more information on modifying,
|
-- Controls the base of generated URLs. For more information on modifying,
|
||||||
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
|
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
|
||||||
approot :: Approot App
|
approot :: Approot App
|
||||||
approot = ApprootRequest $ \app req ->
|
approot = ApprootRequest $ \app req ->
|
||||||
case appRoot $ appSettings app of
|
case appRoot $ appSettings app of
|
||||||
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.
|
||||||
-- Some users may also want to add the defaultCsrfMiddleware, which:
|
-- Some users may also want to add the defaultCsrfMiddleware, which:
|
||||||
-- a) Sets a cookie with a CSRF token in it.
|
-- a) Sets a cookie with a CSRF token in it.
|
||||||
-- 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
|
||||||
-- default-layout-wrapper is the entire page. Since the final
|
-- default-layout-wrapper is the entire page. Since the final
|
||||||
-- value passed to hamletToRepHtml cannot be a widget, this allows
|
-- value passed to hamletToRepHtml cannot be a widget, this allows
|
||||||
-- you to use normal widget features in default-layout.
|
-- you to use normal widget features in default-layout.
|
||||||
|
|
||||||
pc <- widgetToPageContent $ do
|
pc <- widgetToPageContent $ do
|
||||||
$(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
|
-- isAuthorized _ _ = return Authorized
|
||||||
|
|
||||||
|
-- This function creates static content files in the static folder
|
||||||
|
-- and names them based on a hash of their content. This allows
|
||||||
|
-- expiration dates to be set far in the future without worry of
|
||||||
|
-- users receiving stale content.
|
||||||
|
addStaticContent ::
|
||||||
|
Text ->
|
||||||
|
-- \^ The file extension
|
||||||
|
Text ->
|
||||||
|
-- \^ The MIME content type
|
||||||
|
LByteString ->
|
||||||
|
-- \^ The contents of the file
|
||||||
|
Handler (Maybe (Either Text (Route App, [(Text, Text)])))
|
||||||
|
addStaticContent ext mime content = do
|
||||||
|
master <- getYesod
|
||||||
|
let staticDir = appStaticDir $ appSettings master
|
||||||
|
addStaticContentExternal
|
||||||
|
minifym
|
||||||
|
genFileName
|
||||||
|
staticDir
|
||||||
|
(StaticR . flip StaticRoute [])
|
||||||
|
ext
|
||||||
|
mime
|
||||||
|
content
|
||||||
|
where
|
||||||
|
-- Generate a unique filename based on the content itself
|
||||||
|
genFileName lbs = "autogen-" ++ base64md5 lbs
|
||||||
|
|
||||||
-- This function creates static content files in the static folder
|
-- What messages should be logged. The following includes all messages when
|
||||||
-- and names them based on a hash of their content. This allows
|
-- in development, and warnings and errors in production.
|
||||||
-- expiration dates to be set far in the future without worry of
|
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
|
||||||
-- users receiving stale content.
|
shouldLogIO app _source level =
|
||||||
addStaticContent
|
return
|
||||||
:: Text -- ^ The file extension
|
$ appShouldLogAll (appSettings app)
|
||||||
-> Text -- ^ The MIME content type
|
|| level
|
||||||
-> LByteString -- ^ The contents of the file
|
== LevelWarn
|
||||||
-> Handler (Maybe (Either Text (Route App, [(Text, Text)])))
|
|| level
|
||||||
addStaticContent ext mime content = do
|
== LevelError
|
||||||
master <- getYesod
|
|
||||||
let staticDir = appStaticDir $ appSettings master
|
|
||||||
addStaticContentExternal
|
|
||||||
minifym
|
|
||||||
genFileName
|
|
||||||
staticDir
|
|
||||||
(StaticR . flip StaticRoute [])
|
|
||||||
ext
|
|
||||||
mime
|
|
||||||
content
|
|
||||||
where
|
|
||||||
-- Generate a unique filename based on the content itself
|
|
||||||
genFileName lbs = "autogen-" ++ base64md5 lbs
|
|
||||||
|
|
||||||
-- What messages should be logged. The following includes all messages when
|
makeLogger :: App -> IO Logger
|
||||||
-- in development, and warnings and errors in production.
|
makeLogger = return . appLogger
|
||||||
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
|
|
||||||
shouldLogIO app _source level =
|
|
||||||
return $
|
|
||||||
appShouldLogAll (appSettings app)
|
|
||||||
|| level == LevelWarn
|
|
||||||
|| level == LevelError
|
|
||||||
|
|
||||||
makeLogger :: App -> IO Logger
|
|
||||||
makeLogger = return . appLogger
|
|
||||||
|
|
||||||
-- How to run database actions.
|
-- How to run database actions.
|
||||||
instance YesodPersist App where
|
instance YesodPersist App where
|
||||||
type YesodPersistBackend App = SqlBackend
|
type YesodPersistBackend App = SqlBackend
|
||||||
runDB :: SqlPersistT Handler a -> Handler a
|
runDB :: SqlPersistT Handler a -> Handler a
|
||||||
runDB action = do
|
runDB action = do
|
||||||
master <- getYesod
|
master <- getYesod
|
||||||
runSqlPool action $ appConnPool master
|
runSqlPool action $ appConnPool master
|
||||||
|
|
||||||
instance YesodPersistRunner App where
|
instance YesodPersistRunner App where
|
||||||
getDBRunner :: Handler (DBRunner App, Handler ())
|
getDBRunner :: Handler (DBRunner App, Handler ())
|
||||||
getDBRunner = defaultGetDBRunner appConnPool
|
getDBRunner = defaultGetDBRunner appConnPool
|
||||||
|
|
||||||
-- This instance is required to use forms. You can modify renderMessage to
|
-- This instance is required to use forms. You can modify renderMessage to
|
||||||
-- achieve customized and internationalized form validation messages.
|
-- achieve customized and internationalized form validation messages.
|
||||||
instance RenderMessage App FormMessage where
|
instance RenderMessage App FormMessage where
|
||||||
renderMessage :: App -> [Lang] -> FormMessage -> Text
|
renderMessage :: App -> [Lang] -> FormMessage -> Text
|
||||||
renderMessage _ _ = defaultFormMessage
|
renderMessage _ _ = defaultFormMessage
|
||||||
|
|
||||||
-- Useful when writing code that is re-usable outside of the Handler context.
|
-- Useful when writing code that is re-usable outside of the Handler context.
|
||||||
-- An example is background jobs that send email.
|
-- An example is background jobs that send email.
|
||||||
-- This can also be useful for writing code that works across multiple Yesod applications.
|
-- This can also be useful for writing code that works across multiple Yesod applications.
|
||||||
instance HasHttpManager App where
|
instance HasHttpManager App where
|
||||||
getHttpManager :: App -> Manager
|
getHttpManager :: App -> Manager
|
||||||
getHttpManager = appHttpManager
|
getHttpManager = appHttpManager
|
||||||
|
|
||||||
unsafeHandler :: App -> Handler a -> IO a
|
unsafeHandler :: App -> Handler a -> IO a
|
||||||
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
|
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
|
||||||
|
|
@ -189,28 +199,29 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
|
||||||
-- 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
|
-- 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 :: HandlerFor App (Key User)
|
||||||
getUserId = do
|
getUserId = do
|
||||||
mName <- lookupHeader "Remote-User"
|
mName <- lookupHeader "Remote-User"
|
||||||
mUser <- case mName of
|
currentTime <- liftIO getCurrentTime
|
||||||
-- 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 ?
|
mUser <- case mName of
|
||||||
Just name -> runDB $ insertBy $ User (decodeUtf8 name)
|
-- 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 ?
|
||||||
Nothing -> runDB $ insertBy $ User "single-user"
|
Just name -> runDB $ insertBy $ User (decodeUtf8 name) currentTime
|
||||||
case mUser of
|
Nothing -> runDB $ insertBy $ User "single-user" currentTime
|
||||||
Left (Entity userId _) -> return userId
|
case mUser of
|
||||||
Right userId -> return userId
|
Left (Entity userId _) -> return userId
|
||||||
|
Right userId -> return userId
|
||||||
|
|
||||||
dbIfAuth :: GroupId -> ReaderT SqlBackend (HandlerFor App) b -> HandlerFor App b
|
dbIfAuth :: GroupId -> ReaderT SqlBackend (HandlerFor App) b -> HandlerFor App b
|
||||||
dbIfAuth groupId action = do
|
dbIfAuth groupId action = do
|
||||||
-- TODO: decide if we prefer fast (rawSql) or safe (type safe persist query) after in production latency tests
|
-- TODO: decide if we prefer fast (rawSql) or safe (type safe persist query) after in production latency tests
|
||||||
user <- getUserId
|
user <- getUserId
|
||||||
result <- runDB $ selectFirst [GroupUserUser ==. user, GroupUserGroupId ==. groupId] []
|
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"
|
if isNothing result
|
||||||
|
then permissionDenied "you are not logged in or you dont have access to this group"
|
||||||
else runDB action
|
else runDB action
|
||||||
|
|
||||||
getGroups :: Key User -> Handler [Entity Group]
|
getGroups :: Key User -> Handler [Entity Group]
|
||||||
getGroups userId =
|
getGroups userId =
|
||||||
let sql = "SELECT ?? FROM \"group\" JOIN group_user gu ON \"group\".id = gu.group_id WHERE gu.user = ?" in
|
let sql = "SELECT ?? FROM \"group\" JOIN group_user gu ON \"group\".id = gu.group_id WHERE gu.user = ?"
|
||||||
runDB $ rawSql sql [toPersistValue userId]
|
in runDB $ rawSql sql [toPersistValue userId]
|
||||||
|
|
|
||||||
|
|
@ -1,25 +1,36 @@
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE ImportQualifiedPost #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
|
||||||
module Handler.Api where
|
module Handler.Api where
|
||||||
|
|
||||||
import Import
|
import Data.Text qualified as Text
|
||||||
import Database.Persist.Sql (rawSql)
|
|
||||||
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
|
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
|
||||||
import qualified Data.Text as Text
|
import Database.Persist.Sql (rawSql)
|
||||||
|
import Import
|
||||||
|
|
||||||
getApiR :: Int -> Handler TypedContent
|
getApiR :: Int -> Handler TypedContent
|
||||||
getApiR time = do
|
getApiR time = do
|
||||||
-- TODO: use only one runDB
|
-- TODO: use only one runDB (or use joins ?)
|
||||||
userId <- getUserId
|
userId <- getUserId
|
||||||
-- We get all groups no matter what, since else we can't know which groups have been deleted
|
let utcTime = posixSecondsToUTCTime (fromIntegral time)
|
||||||
groups <- getGroups userId
|
-- condition : parent user or group changed
|
||||||
let utcTime = posixSecondsToUTCTime (fromIntegral time)
|
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 > ?;"
|
||||||
let sqlLists = "select ?? from todolist join group_user on todolist.group_id = group_user.group_id and group_user.user = ? join \"group\" on todolist.group_id = \"group\".id and \"group\".last_modified > ?;"
|
-- condition : parent group or list changed
|
||||||
lists <- runDB $ rawSql sqlLists [toPersistValue userId, toPersistValue utcTime]
|
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 > ?;"
|
||||||
let a = lists :: [Entity Todolist]
|
-- condition : parent list changed
|
||||||
let sqlItems = "select ?? from todolist join group_user on todolist.group_id = group_user.group_id and group_user.user = ? join \"group\" on todolist.group_id = \"group\".id and \"group\".last_modified > ? join todolist_item on todolist_item.todolist_id = todolist.id;"
|
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;"
|
||||||
items <- runDB $ rawSql sqlItems [toPersistValue userId, toPersistValue utcTime]
|
runDB $ do
|
||||||
let t = unlines $ map groupToCSV groups <> map todolistToCSV lists <> map todolistItemToCSV items
|
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
|
return $ TypedContent typePlain $ toContent t
|
||||||
|
|
||||||
todolistItemToCSV :: Entity TodolistItem -> Text
|
todolistItemToCSV :: Entity TodolistItem -> Text
|
||||||
|
|
@ -28,9 +39,11 @@ todolistToCSV :: Entity Todolist -> Text
|
||||||
todolistToCSV list = "l," <> fieldToText list
|
todolistToCSV list = "l," <> fieldToText list
|
||||||
groupToCSV :: Entity Group -> Text
|
groupToCSV :: Entity Group -> Text
|
||||||
groupToCSV group = "g," <> fieldToText group
|
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 ?)
|
-- TODO: error management ? (maybe use Either Text Text and then propagate left to handler and send error ?)
|
||||||
fieldToText :: PersistEntity record => Entity record -> Text
|
fieldToText :: (PersistEntity record) => Entity record -> Text
|
||||||
fieldToText field = Text.intercalate "," (map persistValueToText $ entityValues field)
|
fieldToText field = Text.intercalate "," (map persistValueToText $ entityValues field)
|
||||||
|
|
||||||
persistValueToText :: PersistValue -> Text
|
persistValueToText :: PersistValue -> Text
|
||||||
|
|
@ -38,15 +51,15 @@ persistValueToText (PersistText s) = s
|
||||||
persistValueToText (PersistInt64 i) = Text.pack $ show i
|
persistValueToText (PersistInt64 i) = Text.pack $ show i
|
||||||
persistValueToText (PersistUTCTime d) = Text.pack $ show $ floor (utcTimeToPOSIXSeconds d)
|
persistValueToText (PersistUTCTime d) = Text.pack $ show $ floor (utcTimeToPOSIXSeconds d)
|
||||||
persistValueToText (PersistBool b) = if b then "T" else "F"
|
persistValueToText (PersistBool b) = if b then "T" else "F"
|
||||||
persistValueToText _ = error "Wrong input type"
|
persistValueToText _ = error "Wrong input type"
|
||||||
|
|
||||||
getText :: Text
|
getText :: Text
|
||||||
getText = do
|
getText = do
|
||||||
-- GET EVERY GROUP THAT HAS BEEN MODIFIED SINCE TIMESTAMP FROM USER
|
-- GET EVERY GROUP THAT HAS BEEN MODIFIED SINCE TIMESTAMP FROM USER
|
||||||
|
|
||||||
-- GET EVERY TODOLIST THAT HAS BEEN MODIFIED SINCE TIMESTAMP
|
-- GET EVERY TODOLIST THAT HAS BEEN MODIFIED SINCE TIMESTAMP
|
||||||
-- GET EVERY ITEM FROM THESE TODOLISTS
|
-- GET EVERY ITEM FROM THESE TODOLISTS
|
||||||
-- ENCODE ALL OF THEM IN THE TEXTFILE
|
-- ENCODE ALL OF THEM IN THE TEXTFILE
|
||||||
-- SEND IT !
|
-- SEND IT !
|
||||||
-- DONE :)
|
-- DONE :)
|
||||||
error "not done yet"
|
error "not done yet"
|
||||||
|
|
|
||||||
|
|
@ -1,58 +1,68 @@
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||||
{-# HLINT ignore "Replace case with fromMaybe" #-}
|
|
||||||
module Handler.Group where
|
module Handler.Group where
|
||||||
|
|
||||||
|
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
||||||
import Import
|
import Import
|
||||||
import Text.Read
|
import Text.Read
|
||||||
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
|
||||||
getGroupR :: Handler Html
|
getGroupR :: Handler Html
|
||||||
getGroupR = do
|
getGroupR = do
|
||||||
userId <- getUserId
|
userId <- getUserId
|
||||||
groups <- getGroups userId
|
groups <- getGroups userId
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitle "Groups"
|
setTitle "Groups"
|
||||||
$(widgetFile "group")
|
$(widgetFile "group")
|
||||||
postAddGroupR :: Handler Html
|
postAddGroupR :: Handler Html
|
||||||
postAddGroupR = do
|
postAddGroupR = do
|
||||||
g <- runInputPost $ ireq textField "group"
|
g <- runInputPost $ ireq textField "group"
|
||||||
-- TODO: in a newer version, put insertUnique_
|
-- TODO: in a newer version, put insertUnique_
|
||||||
user <- getUserId
|
user <- getUserId
|
||||||
_ <- runDB $ do
|
_ <- runDB $ do
|
||||||
currentTime <- liftIO getCurrentTime
|
currentTime <- liftIO getCurrentTime
|
||||||
gId <- insert $ Group g currentTime
|
gId <- insert $ Group g currentTime
|
||||||
success <- insertUnique $ GroupUser user gId
|
success <- insertUnique $ GroupUser user gId
|
||||||
when (isNothing success) $ delete gId
|
when (isNothing success) $ delete gId
|
||||||
redirect GroupR
|
redirect GroupR
|
||||||
|
|
||||||
getEditGroupR :: Handler Html
|
getEditGroupR :: Handler Html
|
||||||
getEditGroupR = do
|
getEditGroupR = do
|
||||||
userId <- getUserId
|
userId <- getUserId
|
||||||
groups <- getGroups userId
|
groups <- getGroups userId
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
let a e = pack $ show $ fromSqlKey $ entityKey e ::Text
|
let a e = pack $ show $ fromSqlKey $ entityKey e :: Text
|
||||||
setTitle "Groups"
|
setTitle "Groups"
|
||||||
$(widgetFile "edit-group")
|
$(widgetFile "edit-group")
|
||||||
postEditGroupR :: Handler Html
|
postEditGroupR :: Handler Html
|
||||||
postEditGroupR = do
|
postEditGroupR = do
|
||||||
-- TODO: not implemented yet
|
-- TODO: not implemented yet
|
||||||
-- title <- runInputPost $ ireq textField "title"
|
-- title <- runInputPost $ ireq textField "title"
|
||||||
-- users <- runInputPost $ ireq textField "users"
|
-- users <- runInputPost $ ireq textField "users"
|
||||||
-- id <- runInputPost $ ireq intField "id"
|
-- id <- runInputPost $ ireq intField "id"
|
||||||
-- let key = toSqlKey id
|
-- let key = toSqlKey id
|
||||||
-- runDB $ update key [GroupGroup =. title]
|
-- runDB $ update key [GroupGroup =. title]
|
||||||
redirect EditGroupR
|
redirect EditGroupR
|
||||||
postDeleteGroupR :: Handler Html
|
postDeleteGroupR :: Handler Html
|
||||||
postDeleteGroupR = do
|
postDeleteGroupR = do
|
||||||
text <- lookupPostParams "ids"
|
text <- lookupPostParams "ids"
|
||||||
let ints = map (read . unpack) text :: [Int64]
|
let ints = map (read . unpack) text :: [Int64]
|
||||||
let ids = map toSqlKey ints :: [GroupId]
|
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
|
userId <- getUserId
|
||||||
runDB $ deleteWhere [GroupId <-. ids]
|
currentTime <- liftIO getCurrentTime
|
||||||
redirect EditGroupR
|
-- 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
|
||||||
|
|
|
||||||
|
|
@ -1,61 +1,74 @@
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||||
|
|
||||||
{-# HLINT ignore "Replace case with fromMaybe" #-}
|
{-# HLINT ignore "Replace case with fromMaybe" #-}
|
||||||
module Handler.Todolist where
|
module Handler.Todolist where
|
||||||
|
|
||||||
|
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
||||||
import Import
|
import Import
|
||||||
import Text.Read
|
import Text.Read
|
||||||
import Database.Persist.Sql (fromSqlKey, toSqlKey)
|
|
||||||
postAddTodolistR :: GroupId -> Handler Html
|
postAddTodolistR :: GroupId -> Handler Html
|
||||||
postAddTodolistR groupId = do
|
postAddTodolistR groupId = do
|
||||||
list <- runInputPost $ ireq textField "list"
|
list <- runInputPost $ ireq textField "list"
|
||||||
-- TODO: in a newer version, put insertUnique_
|
-- TODO: in a newer version, put insertUnique_
|
||||||
currentTime <- liftIO getCurrentTime
|
currentTime <- liftIO getCurrentTime
|
||||||
_ <- dbIfAuth groupId (insertUnique $ Todolist groupId list currentTime)
|
_ <- dbIfAuth groupId (insertUnique $ Todolist groupId list currentTime)
|
||||||
redirect $ TodolistR groupId
|
redirect $ TodolistR groupId
|
||||||
|
|
||||||
-- TODO: move this to a new handler file
|
|
||||||
getTodolistR :: GroupId -> Handler Html
|
getTodolistR :: GroupId -> Handler Html
|
||||||
getTodolistR groupId = do
|
getTodolistR groupId = do
|
||||||
lists <- dbIfAuth groupId (selectList [TodolistGroupId ==. groupId] [])
|
lists <- dbIfAuth groupId (selectList [TodolistGroupId ==. groupId] [])
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
let getTitle = todolistTitle . entityVal
|
let getTitle = todolistTitle . entityVal
|
||||||
setTitle "todolist"
|
setTitle "todolist"
|
||||||
$(widgetFile "todolist")
|
$(widgetFile "todolist")
|
||||||
|
|
||||||
getEditTodolistR :: GroupId -> Handler Html
|
getEditTodolistR :: GroupId -> Handler Html
|
||||||
getEditTodolistR groupId = do
|
getEditTodolistR groupId = do
|
||||||
lists <- runDB $
|
lists <-
|
||||||
selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
|
runDB
|
||||||
defaultLayout $ do
|
$ selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
|
||||||
let keyToText e = pack $ show $ fromSqlKey $ entityKey e ::Text
|
defaultLayout $ do
|
||||||
setTitle "Groups"
|
let keyToText e = pack $ show $ fromSqlKey $ entityKey e :: Text
|
||||||
$(widgetFile "edit-todolist")
|
setTitle "Groups"
|
||||||
|
$(widgetFile "edit-todolist")
|
||||||
|
|
||||||
postDeleteTodolistR :: GroupId -> Handler Html
|
postDeleteTodolistR :: GroupId -> Handler Html
|
||||||
postDeleteTodolistR groupId = do
|
postDeleteTodolistR groupId = do
|
||||||
text <- lookupPostParams "ids"
|
text <- lookupPostParams "ids"
|
||||||
let ints = map (read . unpack) text :: [Int64]
|
currentTime <- liftIO getCurrentTime
|
||||||
let ids = map toSqlKey ints :: [TodolistId]
|
let ints = map (read . unpack) text :: [Int64]
|
||||||
dbIfAuth groupId (deleteWhere [TodolistId <-. ids])
|
let ids = map toSqlKey ints :: [TodolistId]
|
||||||
redirect $ EditTodolistR groupId
|
dbIfAuth
|
||||||
|
groupId
|
||||||
|
( do
|
||||||
|
deleteWhere [TodolistId <-. ids]
|
||||||
|
update groupId [GroupLastModified =. currentTime]
|
||||||
|
)
|
||||||
|
|
||||||
|
redirect $ EditTodolistR groupId
|
||||||
postEditTodolistR :: GroupId -> Handler Html
|
postEditTodolistR :: GroupId -> Handler Html
|
||||||
postEditTodolistR groupId = error "not done yet"
|
postEditTodolistR groupId = error "not done yet"
|
||||||
|
|
||||||
postAddUserR :: GroupId -> Handler Html
|
postAddUserR :: GroupId -> Handler Html
|
||||||
postAddUserR groupId= do
|
postAddUserR groupId = do
|
||||||
user <- runInputPost $ ireq textField "user"
|
user <- runInputPost $ ireq textField "user"
|
||||||
_ <- dbIfAuth groupId (do
|
_ <-
|
||||||
mUserId <- getBy $ UniqueName user
|
dbIfAuth
|
||||||
case mUserId of
|
groupId
|
||||||
Nothing -> --handle error
|
( do
|
||||||
redirect $ TodolistR groupId
|
mUserId <- getBy $ UniqueName user
|
||||||
|
case mUserId of
|
||||||
|
Nothing ->
|
||||||
|
-- handle error
|
||||||
|
redirect $ TodolistR groupId
|
||||||
Just userId -> insert $ GroupUser (entityKey userId) groupId
|
Just userId -> insert $ GroupUser (entityKey userId) groupId
|
||||||
)
|
)
|
||||||
redirect $ TodolistR groupId
|
redirect $ TodolistR groupId
|
||||||
|
|
|
||||||
|
|
@ -1,91 +1,117 @@
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
|
||||||
{-# LANGUAGE QuasiQuotes #-}
|
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||||
|
|
||||||
{-# HLINT ignore "Replace case with fromMaybe" #-}
|
{-# HLINT ignore "Replace case with fromMaybe" #-}
|
||||||
module Handler.TodolistItem where
|
module Handler.TodolistItem where
|
||||||
|
|
||||||
import Import
|
|
||||||
import Database.Persist.Sql (rawExecute)
|
import Database.Persist.Sql (rawExecute)
|
||||||
|
import Import
|
||||||
|
|
||||||
getTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
getTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||||
getTodolistItemsR groupId todolistId = do
|
getTodolistItemsR groupId todolistId = do
|
||||||
mSortOption <- lookupSession "sort"
|
mSortOption <- lookupSession "sort"
|
||||||
items <- case mSortOption of
|
items <- case mSortOption of
|
||||||
(Just "value") -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Desc TodolistItemValue, Asc TodolistItemId])
|
(Just "value") -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Desc TodolistItemValue, Asc TodolistItemId])
|
||||||
_ -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Asc TodolistItemId])
|
_ -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Asc TodolistItemId])
|
||||||
|
|
||||||
defaultLayout $ do
|
|
||||||
setTitle "items"
|
|
||||||
$(widgetFile "todolist-items")
|
|
||||||
|
|
||||||
|
defaultLayout $ do
|
||||||
|
setTitle "items"
|
||||||
|
$(widgetFile "todolist-items")
|
||||||
|
|
||||||
postCheckTodolistItemR :: GroupId -> TodolistId -> TodolistItemId -> Handler Html
|
postCheckTodolistItemR :: GroupId -> TodolistId -> TodolistItemId -> Handler Html
|
||||||
postCheckTodolistItemR groupId todolistId todolistItemId = do
|
postCheckTodolistItemR groupId todolistId todolistItemId = do
|
||||||
dbIfAuth groupId (rawExecute "UPDATE todolist_item SET value = NOT value WHERE id = ?" [toPersistValue todolistItemId])
|
currentTime <- liftIO getCurrentTime
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
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 -> Handler Html
|
||||||
postAddTodolistItemR groupId todolistId = do
|
postAddTodolistItemR groupId todolistId = do
|
||||||
item <- runInputPost $ ireq textField "item"
|
currentTime <- liftIO getCurrentTime
|
||||||
_ <- dbIfAuth groupId (insert_ $ TodolistItem todolistId False item)
|
item <- runInputPost $ ireq textField "item"
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
_ <-
|
||||||
|
dbIfAuth
|
||||||
|
groupId
|
||||||
|
( do
|
||||||
|
insert_ $ TodolistItem todolistId False item
|
||||||
|
update todolistId [TodolistLastModified =. currentTime]
|
||||||
|
)
|
||||||
|
redirect $ TodolistItemsR groupId todolistId
|
||||||
|
|
||||||
getEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
getEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||||
getEditTodolistItemsR groupId todolistId = do
|
getEditTodolistItemsR groupId todolistId = do
|
||||||
items <- dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [])
|
items <- dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [])
|
||||||
let text = unlines $ map getText items
|
let text = unlines $ map getText items
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitle "edit"
|
setTitle "edit"
|
||||||
$(widgetFile "edit-todolist-items")
|
$(widgetFile "edit-todolist-items")
|
||||||
|
|
||||||
postEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
postEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||||
postEditTodolistItemsR groupId todolistId = do
|
postEditTodolistItemsR groupId todolistId = do
|
||||||
mText <- runInputPost $ iopt textField "text"
|
currentTime <- liftIO getCurrentTime
|
||||||
let xs = case mText of
|
mText <- runInputPost $ iopt textField "text"
|
||||||
(Just text) -> getItems text todolistId
|
let xs = case mText of
|
||||||
Nothing -> []
|
(Just text) -> getItems text todolistId
|
||||||
dbIfAuth groupId (do
|
Nothing -> [] -- Case statement used to let delete all without error TODO: check if can use flatmap instead ?
|
||||||
|
dbIfAuth
|
||||||
|
groupId
|
||||||
|
( do
|
||||||
deleteWhere [TodolistItemTodolistId ==. todolistId]
|
deleteWhere [TodolistItemTodolistId ==. todolistId]
|
||||||
insertMany_ xs)
|
insertMany_ xs
|
||||||
|
update todolistId [TodolistLastModified =. currentTime]
|
||||||
|
)
|
||||||
|
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
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 -> Handler Html
|
||||||
postTrimTodolistItemsR groupId todolistId = do
|
postTrimTodolistItemsR groupId todolistId = do
|
||||||
dbIfAuth groupId (deleteWhere [TodolistItemTodolistId ==. todolistId, TodolistItemValue ==. True])
|
currentTime <- liftIO getCurrentTime
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
dbIfAuth
|
||||||
|
groupId
|
||||||
|
( do
|
||||||
|
deleteWhere [TodolistItemTodolistId ==. todolistId, TodolistItemValue ==. True]
|
||||||
|
update todolistId [TodolistLastModified =. currentTime]
|
||||||
|
)
|
||||||
|
redirect $ TodolistItemsR groupId todolistId
|
||||||
|
|
||||||
postSortTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
postSortTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||||
postSortTodolistItemsR groupId todolistId = do
|
postSortTodolistItemsR groupId todolistId = do
|
||||||
mSession <- lookupSession "sort"
|
mSession <- lookupSession "sort"
|
||||||
case mSession of
|
case mSession of
|
||||||
(Just "value") -> setSession "sort" "id"
|
(Just "value") -> setSession "sort" "id"
|
||||||
_ -> setSession "sort" "value"
|
_ -> setSession "sort" "value"
|
||||||
redirect $ TodolistItemsR groupId todolistId
|
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
|
||||||
|
|
|
||||||
|
|
@ -20,10 +20,6 @@
|
||||||
snapshot:
|
snapshot:
|
||||||
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml
|
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml
|
||||||
|
|
||||||
nix:
|
|
||||||
enable: true
|
|
||||||
pure: false
|
|
||||||
|
|
||||||
# User packages to be built.
|
# User packages to be built.
|
||||||
# Various formats can be used as shown in the example below.
|
# Various formats can be used as shown in the example below.
|
||||||
#
|
#
|
||||||
|
|
@ -53,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/topics/lock_files
|
# https://docs.haskellstack.org/en/stable/lock_files
|
||||||
|
|
||||||
packages: []
|
packages: []
|
||||||
snapshots:
|
snapshots:
|
||||||
|
|
|
||||||
|
|
@ -1,11 +1,10 @@
|
||||||
<!-- Page Contents -->
|
<!-- Page Contents -->
|
||||||
<div .container>
|
<div .container>
|
||||||
$maybe msg <- mmsg
|
$maybe msg <- mmsg
|
||||||
<div>#{msg}
|
<div>#{msg}
|
||||||
|
^{widget}
|
||||||
^{widget}
|
|
||||||
|
|
||||||
<!-- Footer -->
|
<!-- Footer -->
|
||||||
<footer>
|
<footer>
|
||||||
<p>
|
<p>
|
||||||
#{appCopyright $ appSettings master}
|
#{appCopyright $ appSettings master}
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
<form action=@{DeleteGroupR} method="POST">
|
<form action=@{DeleteGroupR} method="POST">
|
||||||
<ul>
|
<ul>
|
||||||
$forall group <- groups
|
$forall group <- groups
|
||||||
<li>
|
<li>
|
||||||
<input type="checkbox" name="ids" value="#{a group}">
|
<input type="checkbox" name="ids" value="#{a group}">
|
||||||
<a href="">#{(groupGroup . entityVal) group}
|
<a href="">#{(groupGroup . entityVal) group}
|
||||||
<button type=submit>Delete selected
|
<button type=submit>Delete selected
|
||||||
<a href=@{GroupR}>Back
|
<a href=@{GroupR}>Back
|
||||||
|
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
||||||
<form action=@{EditTodolistItemsR groupId todolistId} method=POST>
|
<form action=@{EditTodolistItemsR groupId todolistId} method=POST>
|
||||||
<label for="edit text area">Edit todolist
|
<label for="edit text area">Edit todolist
|
||||||
<br>
|
<br>
|
||||||
<textarea id="edit text area" name=text rows=30 cols=50 placeholder="[x] wake up1 [x] eat [ ] sleep [ ] repeat">#{text}
|
<textarea id="edit text area" name=text rows=30 cols=50 placeholder="[x] wake up1 [x] eat [ ] sleep [ ] repeat">#{text}
|
||||||
<br>
|
<br>
|
||||||
<button type="submit">edit
|
<button type="submit">edit
|
||||||
|
|
|
||||||
|
|
@ -1,8 +1,8 @@
|
||||||
<form action=@{DeleteTodolistR groupId} method="POST">
|
<form action=@{DeleteTodolistR groupId} method="POST">
|
||||||
<ul>
|
<ul>
|
||||||
$forall list <- lists
|
$forall list <- lists
|
||||||
<li>
|
<li>
|
||||||
<input type="checkbox" name="ids" value="#{keyToText list}">
|
<input type="checkbox" name="ids" value="#{keyToText list}">
|
||||||
<a href="">#{(todolistTitle . entityVal) list}
|
<a href="">#{(todolistTitle . entityVal) list}
|
||||||
<button type=submit>Delete selected
|
<button type=submit>Delete selected
|
||||||
<a href=@{TodolistR groupId}>Back
|
<a href=@{TodolistR groupId}>Back
|
||||||
|
|
|
||||||
|
|
@ -1,9 +1,9 @@
|
||||||
<a href=@{GroupR}>Home
|
<a href=@{GroupR}>Home
|
||||||
<ul>
|
<ul>
|
||||||
$forall group <- groups
|
$forall group <- groups
|
||||||
<li>
|
<li>
|
||||||
<a href=@{TodolistR $ entityKey group}>#{(groupGroup . entityVal) group}
|
<a href=@{TodolistR $ entityKey group}>#{(groupGroup . entityVal) group}
|
||||||
<form action=@{AddGroupR} method="post">
|
<form action=@{AddGroupR} method="post">
|
||||||
<input type="text" name="group" placeholder="new group">
|
<input type="text" name="group" placeholder="new group">
|
||||||
<button type="submit">add
|
<button type="submit">add
|
||||||
<a href=@{EditGroupR}>Edit
|
<a href=@{EditGroupR}>Edit
|
||||||
|
|
|
||||||
|
|
@ -1,141 +0,0 @@
|
||||||
<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>
|
|
||||||
|
|
@ -1,34 +0,0 @@
|
||||||
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);
|
|
||||||
},
|
|
||||||
});
|
|
||||||
|
|
||||||
});
|
|
||||||
});
|
|
||||||
|
|
@ -1,13 +0,0 @@
|
||||||
h2##{aDomId} {
|
|
||||||
color: #990
|
|
||||||
}
|
|
||||||
|
|
||||||
li {
|
|
||||||
line-height: 2em;
|
|
||||||
font-size: 16px
|
|
||||||
}
|
|
||||||
|
|
||||||
##{commentTextareaId} {
|
|
||||||
width: 400px;
|
|
||||||
height: 100px;
|
|
||||||
}
|
|
||||||
|
|
@ -1,10 +0,0 @@
|
||||||
<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 +1,17 @@
|
||||||
<a href=@{GroupR}>Home
|
<a href=@{GroupR}>Home
|
||||||
|
|
||||||
<a href=@{TodolistR groupId}>Lists
|
<a href=@{TodolistR groupId}>Lists
|
||||||
<ul>
|
<ul>
|
||||||
$forall item <- items
|
$forall item <- items
|
||||||
<li>
|
<li>
|
||||||
<form action=@{CheckTodolistItemR groupId todolistId (entityKey item)} method="POST">
|
<form action=@{CheckTodolistItemR groupId todolistId (entityKey item)} method="POST">
|
||||||
<button type="submit">#{getText item}
|
<button type="submit">#{getText item}
|
||||||
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
||||||
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
||||||
<input type="text" name="item" placeholder="new item">
|
<input type="text" name="item" placeholder="new item">
|
||||||
<button type="submit">add
|
<button type="submit">add
|
||||||
<form action=@{TrimTodolistItemsR groupId todolistId} method="post">
|
<form action=@{TrimTodolistItemsR groupId todolistId} method="post">
|
||||||
<button type="submit">trim
|
<button type="submit">trim
|
||||||
<form action=@{SortTodolistItemsR groupId todolistId} method="post">
|
<form action=@{SortTodolistItemsR groupId todolistId} method="post">
|
||||||
<button type="submit">sort
|
<button type="submit">sort
|
||||||
<a href=@{EditTodolistItemsR groupId todolistId}>Edit
|
<a href=@{EditTodolistItemsR groupId todolistId}>Edit
|
||||||
|
|
|
||||||
|
|
@ -1,12 +1,12 @@
|
||||||
<a href=@{GroupR}>Home
|
<a href=@{GroupR}>Home
|
||||||
<ul>
|
<ul>
|
||||||
$forall list <- lists
|
$forall list <- lists
|
||||||
<li>
|
<li>
|
||||||
<a href=@{TodolistItemsR groupId (entityKey list)}>#{getTitle list}
|
<a href=@{TodolistItemsR groupId (entityKey list)}>#{getTitle list}
|
||||||
<form action=@{AddTodolistR groupId} method="post">
|
<form action=@{AddTodolistR groupId} method="post">
|
||||||
<input type="text" name="list" placeholder="new list">
|
<input type="text" name="list" placeholder="new list">
|
||||||
<button type="submit">add
|
<button type="submit">add
|
||||||
<form action=@{AddUserR groupId} method="post">
|
<form action=@{AddUserR groupId} method="post">
|
||||||
<input type="text" name="user" placeholder="new user">
|
<input type="text" name="user" placeholder="new user">
|
||||||
<button type="submit">share
|
<button type="submit">share
|
||||||
<a href=@{EditTodolistR groupId}>Edit
|
<a href=@{EditTodolistR groupId}>Edit
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue