api ready

This commit is contained in:
Stuce 2025-07-14 16:06:17 +02:00
parent 67d88bd31b
commit c4b57d7a29
20 changed files with 440 additions and 568 deletions

View file

@ -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 (I sadly don't use nix develop at the moment) ## 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)

View file

@ -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

View file

@ -1,34 +1,38 @@
{-# 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 Control.Monad.Logger (LogSource)
import Data.Kind (Type) import Data.Kind (Type)
import Database.Persist.Sql (ConnectionPool, runSqlPool, rawSql) import Database.Persist.Sql (ConnectionPool, rawSql, runSqlPool)
import Import.NoFoundation
import Text.Hamlet (hamletFile) import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym) import Text.Jasmine (minifym)
import Control.Monad.Logger (LogSource)
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger) import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe import Yesod.Core.Unsafe qualified 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.
, appConnPool :: ConnectionPool
-- ^ Database connection pool.
, appHttpManager :: Manager , appHttpManager :: Manager
, appLogger :: Logger , appLogger :: Logger
} }
@ -61,8 +65,10 @@ 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.
@ -116,16 +122,18 @@ instance Yesod App where
-- -- Routes not requiring authentication. -- -- Routes not requiring authentication.
-- isAuthorized _ _ = return Authorized -- 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 -- ^ The file extension Text ->
-> Text -- ^ The MIME content type -- \^ The file extension
-> LByteString -- ^ The contents of the file Text ->
-> Handler (Maybe (Either Text (Route App, [(Text, Text)]))) -- \^ The MIME content type
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
@ -145,10 +153,12 @@ 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 == LevelWarn || level
|| level == LevelError == LevelWarn
|| level
== LevelError
makeLogger :: App -> IO Logger makeLogger :: App -> IO Logger
makeLogger = return . appLogger makeLogger = return . appLogger
@ -189,15 +199,15 @@ 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"
currentTime <- liftIO getCurrentTime
mUser <- case mName of 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 ? -- 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) Just name -> runDB $ insertBy $ User (decodeUtf8 name) currentTime
Nothing -> runDB $ insertBy $ User "single-user" Nothing -> runDB $ insertBy $ User "single-user" currentTime
case mUser of case mUser of
Left (Entity userId _) -> return userId Left (Entity userId _) -> return userId
Right userId -> return userId Right userId -> return userId
@ -207,10 +217,11 @@ 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]

View file

@ -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
groups <- getGroups userId
let utcTime = posixSecondsToUTCTime (fromIntegral time) let utcTime = posixSecondsToUTCTime (fromIntegral time)
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 user or group changed
lists <- runDB $ rawSql sqlLists [toPersistValue userId, toPersistValue utcTime] 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 a = lists :: [Entity Todolist] -- condition : parent group or 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 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 > ?;"
items <- runDB $ rawSql sqlItems [toPersistValue userId, toPersistValue utcTime] -- condition : parent list changed
let t = unlines $ map groupToCSV groups <> map todolistToCSV lists <> map todolistItemToCSV items 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 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

View file

@ -1,17 +1,18 @@
{-# 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
@ -53,6 +54,15 @@ 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
-- 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 redirect EditGroupR

View file

@ -1,17 +1,19 @@
{-# 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"
@ -20,7 +22,6 @@ postAddTodolistR groupId = do
_ <- 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] [])
@ -31,8 +32,9 @@ getTodolistR groupId = do
getEditTodolistR :: GroupId -> Handler Html getEditTodolistR :: GroupId -> Handler Html
getEditTodolistR groupId = do getEditTodolistR groupId = do
lists <- runDB $ lists <-
selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle] runDB
$ selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
defaultLayout $ do defaultLayout $ do
let keyToText e = pack $ show $ fromSqlKey $ entityKey e :: Text let keyToText e = pack $ show $ fromSqlKey $ entityKey e :: Text
setTitle "Groups" setTitle "Groups"
@ -41,9 +43,16 @@ getEditTodolistR groupId = do
postDeleteTodolistR :: GroupId -> Handler Html postDeleteTodolistR :: GroupId -> Handler Html
postDeleteTodolistR groupId = do postDeleteTodolistR groupId = do
text <- lookupPostParams "ids" text <- lookupPostParams "ids"
currentTime <- liftIO getCurrentTime
let ints = map (read . unpack) text :: [Int64] let ints = map (read . unpack) text :: [Int64]
let ids = map toSqlKey ints :: [TodolistId] let ids = map toSqlKey ints :: [TodolistId]
dbIfAuth groupId (deleteWhere [TodolistId <-. ids]) dbIfAuth
groupId
( do
deleteWhere [TodolistId <-. ids]
update groupId [GroupLastModified =. currentTime]
)
redirect $ EditTodolistR groupId redirect $ EditTodolistR groupId
postEditTodolistR :: GroupId -> Handler Html postEditTodolistR :: GroupId -> Handler Html
postEditTodolistR groupId = error "not done yet" postEditTodolistR groupId = error "not done yet"
@ -51,10 +60,14 @@ 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 _ <-
dbIfAuth
groupId
( do
mUserId <- getBy $ UniqueName user mUserId <- getBy $ UniqueName user
case mUserId of case mUserId of
Nothing -> --handle error Nothing ->
-- handle error
redirect $ TodolistR groupId redirect $ TodolistR groupId
Just userId -> insert $ GroupUser (entityKey userId) groupId Just userId -> insert $ GroupUser (entityKey userId) groupId
) )

View file

@ -1,16 +1,17 @@
{-# 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
@ -23,17 +24,28 @@ getTodolistItemsR groupId todolistId = do
setTitle "items" setTitle "items"
$(widgetFile "todolist-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
dbIfAuth
groupId
( do
rawExecute "UPDATE todolist_item SET value = NOT value WHERE id = ?" [toPersistValue todolistItemId]
update todolistId [TodolistLastModified =. currentTime]
)
redirect $ TodolistItemsR groupId todolistId redirect $ TodolistItemsR groupId todolistId
postAddTodolistItemR :: GroupId -> TodolistId -> Handler Html postAddTodolistItemR :: GroupId -> TodolistId -> Handler Html
postAddTodolistItemR groupId todolistId = do postAddTodolistItemR groupId todolistId = do
currentTime <- liftIO getCurrentTime
item <- runInputPost $ ireq textField "item" item <- runInputPost $ ireq textField "item"
_ <- dbIfAuth groupId (insert_ $ TodolistItem todolistId False item) _ <-
dbIfAuth
groupId
( do
insert_ $ TodolistItem todolistId False item
update todolistId [TodolistLastModified =. currentTime]
)
redirect $ TodolistItemsR groupId todolistId redirect $ TodolistItemsR groupId todolistId
getEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html getEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
@ -46,19 +58,44 @@ getEditTodolistItemsR groupId todolistId = do
postEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html postEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
postEditTodolistItemsR groupId todolistId = do postEditTodolistItemsR groupId todolistId = do
currentTime <- liftIO getCurrentTime
mText <- runInputPost $ iopt textField "text" mText <- runInputPost $ iopt textField "text"
let xs = case mText of let xs = case mText of
(Just text) -> getItems text todolistId (Just text) -> getItems text todolistId
Nothing -> [] Nothing -> [] -- Case statement used to let delete all without error TODO: check if can use flatmap instead ?
dbIfAuth groupId (do 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
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 :: Entity TodolistItem -> Text
getText item = getText item =
if value then "[x] " <> name if value
then "[x] " <> name
else "[ ] " <> name else "[ ] " <> name
where where
value = (todolistItemValue . entityVal) item value = (todolistItemValue . entityVal) item
@ -66,7 +103,8 @@ getText item =
getItems :: Text -> TodolistId -> [TodolistItem] getItems :: Text -> TodolistId -> [TodolistItem]
getItems text todolistId = map read (lines text) getItems text todolistId = map read (lines text)
where read line = do where
read line = do
let (d, n) = splitAt 4 line let (d, n) = splitAt 4 line
let let
value = case d of value = case d of
@ -77,15 +115,3 @@ getItems text todolistId = map read (lines text)
"" -> error "empty name" "" -> error "empty name"
something -> filter (/= '\r') something something -> filter (/= '\r') something
TodolistItem todolistId value name TodolistItem todolistId value name
postTrimTodolistItemsR :: GroupId -> TodolistId -> Handler Html
postTrimTodolistItemsR groupId todolistId = do
dbIfAuth groupId (deleteWhere [TodolistItemTodolistId ==. todolistId, TodolistItemValue ==. True])
redirect $ TodolistItemsR groupId todolistId
postSortTodolistItemsR :: GroupId -> TodolistId -> Handler Html
postSortTodolistItemsR groupId todolistId = do
mSession <- lookupSession "sort"
case mSession of
(Just "value") -> setSession "sort" "id"
_ -> setSession "sort" "value"
redirect $ TodolistItemsR groupId todolistId

View file

@ -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

View file

@ -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:

View file

@ -2,7 +2,6 @@
<div .container> <div .container>
$maybe msg <- mmsg $maybe msg <- mmsg
<div>#{msg} <div>#{msg}
^{widget} ^{widget}
<!-- Footer --> <!-- Footer -->

View file

@ -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>

View file

@ -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);
},
});
});
});

View file

@ -1,13 +0,0 @@
h2##{aDomId} {
color: #990
}
li {
line-height: 2em;
font-size: 16px
}
##{commentTextareaId} {
width: 400px;
height: 100px;
}

View file

@ -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>!