Stuce/sTodo
1
0
Fork 0
Code Issues Pull requests Projects Releases 3 Packages Wiki Activity Actions

api ready

Browse source
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
Download patch file Download diff file Expand all files Collapse all files

6
README.md
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 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)
- [ ] use getRep and provideRep to make text/javascript response as alternatives to html
- [ ] document api to help create clients
## Version 0.0.3
Simple todo list webapp.
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 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
- that's it, the goal is to keep it minimal !!!
# Development
## 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)

2
config/models.persistentmodels
View file

@ -10,9 +10,9 @@ Todolist
title Text
lastModified UTCTime
UniqueListPair groupId title
deriving Show
User
name Text
lastModified UTCTime
UniqueName name
Group
group Text

81
src/Foundation.hs
View file

@ -1,34 +1,38 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Foundation where
import Import.NoFoundation
import Control.Monad.Logger (LogSource)
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.Jasmine (minifym)
import Control.Monad.Logger (LogSource)
import Yesod.Default.Util (addStaticContentExternal)
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
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
{- | The foundation datatype for your application. This can be a good place to
keep settings and values requiring initialization before your application
starts running, such as database connections. Every handler will have
access to the data present here.
-}
data App = App
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appStatic :: Static
-- ^ Settings for static file serving.
, appConnPool :: ConnectionPool
-- ^ Database connection pool.
, appHttpManager :: Manager
, appLogger :: Logger
}
@ -61,8 +65,10 @@ mkYesodData "App" $(parseRoutesFile "config/routes.yesodroutes")
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
-- | A convenient synonym for database access functions.
type DB a = forall (m :: Type -> Type).
(MonadUnliftIO m) => ReaderT SqlBackend m a
type DB a =
forall (m :: Type -> Type).
(MonadUnliftIO m) =>
ReaderT SqlBackend m a
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
@ -116,16 +122,18 @@ instance Yesod App where
-- -- Routes not requiring authentication.
-- 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 ::
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
@ -145,10 +153,12 @@ instance Yesod App where
-- in development, and warnings and errors in production.
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return $
appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
return
$ appShouldLogAll (appSettings app)
|| level
== LevelWarn
|| level
== LevelError
makeLogger :: App -> IO Logger
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/i18n-messages-in-the-scaffolding
-- TODO: complete implementation should short circuit if multi user is on but no user exist, to enforce policy safely
getUserId :: HandlerFor App (Key User)
getUserId = do
mName <- lookupHeader "Remote-User"
currentTime <- liftIO getCurrentTime
mUser <- case mName of
-- TODO: make remote user an argument to make it usable not only with authelia, and maybe do a check for good mesure when nothing is found ?
Just name -> runDB $ insertBy $ User (decodeUtf8 name)
Nothing -> runDB $ insertBy $ User "single-user"
Just name -> runDB $ insertBy $ User (decodeUtf8 name) currentTime
Nothing -> runDB $ insertBy $ User "single-user" currentTime
case mUser of
Left (Entity userId _) -> return userId
Right userId -> return userId
@ -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
user <- getUserId
result <- runDB $ selectFirst [GroupUserUser ==. user, GroupUserGroupId ==. groupId] []
if isNothing result then permissionDenied "you are not logged in or you dont have access to this group"
if isNothing result
then permissionDenied "you are not logged in or you dont have access to this group"
else runDB action
getGroups :: Key User -> Handler [Entity Group]
getGroups userId =
let sql = "SELECT ?? FROM \"group\" JOIN group_user gu ON \"group\".id = gu.group_id WHERE gu.user = ?" in
runDB $ rawSql sql [toPersistValue userId]
let sql = "SELECT ?? FROM \"group\" JOIN group_user gu ON \"group\".id = gu.group_id WHERE gu.user = ?"
in runDB $ rawSql sql [toPersistValue userId]

41
src/Handler/Api.hs
View file

@ -1,25 +1,36 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Handler.Api where
import Import
import Database.Persist.Sql (rawSql)
import Data.Text qualified as Text
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 time = do
-- TODO: use only one runDB
-- TODO: use only one runDB (or use joins ?)
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 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 > ?;"
lists <- runDB $ rawSql sqlLists [toPersistValue userId, toPersistValue utcTime]
let a = lists :: [Entity Todolist]
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;"
items <- runDB $ rawSql sqlItems [toPersistValue userId, toPersistValue utcTime]
let t = unlines $ map groupToCSV groups <> map todolistToCSV lists <> map todolistItemToCSV items
-- condition : parent user or group changed
let sqlUpdatedGroups = "select ?? from \"group\" join group_user gu on \"group\".id = gu.group_id where gu.user = ? where \"group\".last_modified > ? or user.last_modified > ?;"
-- condition : parent group or list changed
let sqlUpdatedLists = "select ?? from todolist join group_user on todolist.group_id = group_user.group_id and group_user.user = ? join \"group\" as g on g.id = todolist.id where list.last_modified > ? or g.last_modified > ?;"
-- condition : parent list changed
let sqlUpdatedItems = "select ?? from todolist where todolist.last_modified > ? join group_user on todolist.group_id = group_user.group_id and group_user.user = ? join todolist_item on todolist_item.todolist_id = todolist.id;"
runDB $ do
user <- selectList [UserId ==. userId, UserLastModified >. utcTime] []
groups <- rawSql sqlUpdatedGroups [toPersistValue userId, toPersistValue utcTime, toPersistValue utcTime]
lists <- rawSql sqlUpdatedLists [toPersistValue userId, toPersistValue utcTime, toPersistValue utcTime]
items <- rawSql sqlUpdatedItems [toPersistValue utcTime, toPersistValue userId]
let t =
unlines
$ map userToCSV user
<> map groupToCSV groups
<> map todolistToCSV lists
<> map todolistItemToCSV items
return $ TypedContent typePlain $ toContent t
todolistItemToCSV :: Entity TodolistItem -> Text
@ -28,9 +39,11 @@ todolistToCSV :: Entity Todolist -> Text
todolistToCSV list = "l," <> fieldToText list
groupToCSV :: Entity Group -> Text
groupToCSV group = "g," <> fieldToText group
userToCSV :: Entity User -> Text
userToCSV user = "u," <> fieldToText user
-- TODO: error management ? (maybe use Either Text Text and then propagate left to handler and send error ?)
fieldToText :: PersistEntity record => Entity record -> Text
fieldToText :: (PersistEntity record) => Entity record -> Text
fieldToText field = Text.intercalate "," (map persistValueToText $ entityValues field)
persistValueToText :: PersistValue -> Text

32
src/Handler/Group.hs
View file

@ -1,17 +1,18 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Replace case with fromMaybe" #-}
module Handler.Group where
import Database.Persist.Sql (fromSqlKey, toSqlKey)
import Import
import Text.Read
import Database.Persist.Sql (fromSqlKey, toSqlKey)
getGroupR :: Handler Html
getGroupR = do
userId <- getUserId
@ -36,7 +37,7 @@ getEditGroupR = do
userId <- getUserId
groups <- getGroups userId
defaultLayout $ do
let a e = pack $ show $ fromSqlKey $ entityKey e ::Text
let a e = pack $ show $ fromSqlKey $ entityKey e :: Text
setTitle "Groups"
$(widgetFile "edit-group")
postEditGroupR :: Handler Html
@ -53,6 +54,15 @@ postDeleteGroupR = do
text <- lookupPostParams "ids"
let ints = map (read . unpack) text :: [Int64]
let ids = map toSqlKey ints :: [GroupId]
-- TODO: make sure the user has access to it aswell (this only works now for single user), and handle group owned by many
runDB $ deleteWhere [GroupId <-. ids]
userId <- getUserId
currentTime <- liftIO getCurrentTime
-- TODO: test this and maybe change it to sql to be more efficient ?
when (ids /= [])
$ runDB
$ do
update userId [UserLastModified =. currentTime]
deleteWhere [GroupUserGroupId <-. ids, GroupUserUser ==. userId]
nonOrphans <- selectList [GroupUserGroupId <-. ids] []
let nonOrphansIds = map (groupUserGroupId . entityVal) nonOrphans
deleteWhere [GroupId <-. ids, GroupId /<-. nonOrphansIds]
redirect EditGroupR

43
src/Handler/Todolist.hs
View file

@ -1,17 +1,19 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Replace case with fromMaybe" #-}
module Handler.Todolist where
import Database.Persist.Sql (fromSqlKey, toSqlKey)
import Import
import Text.Read
import Database.Persist.Sql (fromSqlKey, toSqlKey)
postAddTodolistR :: GroupId -> Handler Html
postAddTodolistR groupId = do
list <- runInputPost $ ireq textField "list"
@ -20,7 +22,6 @@ postAddTodolistR groupId = do
_ <- dbIfAuth groupId (insertUnique $ Todolist groupId list currentTime)
redirect $ TodolistR groupId
-- TODO: move this to a new handler file
getTodolistR :: GroupId -> Handler Html
getTodolistR groupId = do
lists <- dbIfAuth groupId (selectList [TodolistGroupId ==. groupId] [])
@ -31,30 +32,42 @@ getTodolistR groupId = do
getEditTodolistR :: GroupId -> Handler Html
getEditTodolistR groupId = do
lists <- runDB $
selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
lists <-
runDB
$ selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
defaultLayout $ do
let keyToText e = pack $ show $ fromSqlKey $ entityKey e ::Text
let keyToText e = pack $ show $ fromSqlKey $ entityKey e :: Text
setTitle "Groups"
$(widgetFile "edit-todolist")
postDeleteTodolistR :: GroupId -> Handler Html
postDeleteTodolistR groupId = do
text <- lookupPostParams "ids"
currentTime <- liftIO getCurrentTime
let ints = map (read . unpack) text :: [Int64]
let ids = map toSqlKey ints :: [TodolistId]
dbIfAuth groupId (deleteWhere [TodolistId <-. ids])
dbIfAuth
groupId
( do
deleteWhere [TodolistId <-. ids]
update groupId [GroupLastModified =. currentTime]
)
redirect $ EditTodolistR groupId
postEditTodolistR :: GroupId -> Handler Html
postEditTodolistR groupId = error "not done yet"
postAddUserR :: GroupId -> Handler Html
postAddUserR groupId= do
postAddUserR groupId = do
user <- runInputPost $ ireq textField "user"
_ <- dbIfAuth groupId (do
_ <-
dbIfAuth
groupId
( do
mUserId <- getBy $ UniqueName user
case mUserId of
Nothing -> --handle error
Nothing ->
-- handle error
redirect $ TodolistR groupId
Just userId -> insert $ GroupUser (entityKey userId) groupId
)

82
src/Handler/TodolistItem.hs
View file

@ -1,16 +1,17 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Replace case with fromMaybe" #-}
module Handler.TodolistItem where
import Import
import Database.Persist.Sql (rawExecute)
import Import
getTodolistItemsR :: GroupId -> TodolistId -> Handler Html
getTodolistItemsR groupId todolistId = do
@ -23,17 +24,28 @@ getTodolistItemsR groupId todolistId = do
setTitle "items"
$(widgetFile "todolist-items")
postCheckTodolistItemR :: GroupId -> TodolistId -> TodolistItemId -> Handler Html
postCheckTodolistItemR groupId todolistId todolistItemId = do
dbIfAuth groupId (rawExecute "UPDATE todolist_item SET value = NOT value WHERE id = ?" [toPersistValue todolistItemId])
currentTime <- liftIO getCurrentTime
dbIfAuth
groupId
( do
rawExecute "UPDATE todolist_item SET value = NOT value WHERE id = ?" [toPersistValue todolistItemId]
update todolistId [TodolistLastModified =. currentTime]
)
redirect $ TodolistItemsR groupId todolistId
postAddTodolistItemR :: GroupId -> TodolistId -> Handler Html
postAddTodolistItemR groupId todolistId = do
currentTime <- liftIO getCurrentTime
item <- runInputPost $ ireq textField "item"
_ <- dbIfAuth groupId (insert_ $ TodolistItem todolistId False item)
_ <-
dbIfAuth
groupId
( do
insert_ $ TodolistItem todolistId False item
update todolistId [TodolistLastModified =. currentTime]
)
redirect $ TodolistItemsR groupId todolistId
getEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
@ -46,19 +58,44 @@ getEditTodolistItemsR groupId todolistId = do
postEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
postEditTodolistItemsR groupId todolistId = do
currentTime <- liftIO getCurrentTime
mText <- runInputPost $ iopt textField "text"
let xs = case mText of
(Just text) -> getItems text todolistId
Nothing -> []
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]
insertMany_ xs)
insertMany_ xs
update todolistId [TodolistLastModified =. currentTime]
)
redirect $ TodolistItemsR groupId todolistId
postTrimTodolistItemsR :: GroupId -> TodolistId -> Handler Html
postTrimTodolistItemsR groupId todolistId = do
currentTime <- liftIO getCurrentTime
dbIfAuth
groupId
( do
deleteWhere [TodolistItemTodolistId ==. todolistId, TodolistItemValue ==. True]
update todolistId [TodolistLastModified =. currentTime]
)
redirect $ TodolistItemsR groupId todolistId
postSortTodolistItemsR :: GroupId -> TodolistId -> Handler Html
postSortTodolistItemsR groupId todolistId = do
mSession <- lookupSession "sort"
case mSession of
(Just "value") -> setSession "sort" "id"
_ -> setSession "sort" "value"
redirect $ TodolistItemsR groupId todolistId
getText :: Entity TodolistItem -> Text
getText item =
if value then "[x] " <> name
if value
then "[x] " <> name
else "[ ] " <> name
where
value = (todolistItemValue . entityVal) item
@ -66,7 +103,8 @@ getText item =
getItems :: Text -> TodolistId -> [TodolistItem]
getItems text todolistId = map read (lines text)
where read line = do
where
read line = do
let (d, n) = splitAt 4 line
let
value = case d of
@ -77,15 +115,3 @@ getItems text todolistId = map read (lines text)
"" -> error "empty name"
something -> filter (/= '\r') something
TodolistItem todolistId value name
postTrimTodolistItemsR :: GroupId -> TodolistId -> Handler Html
postTrimTodolistItemsR groupId todolistId = do
dbIfAuth groupId (deleteWhere [TodolistItemTodolistId ==. todolistId, TodolistItemValue ==. True])
redirect $ TodolistItemsR groupId todolistId
postSortTodolistItemsR :: GroupId -> TodolistId -> Handler Html
postSortTodolistItemsR groupId todolistId = do
mSession <- lookupSession "sort"
case mSession of
(Just "value") -> setSession "sort" "id"
_ -> setSession "sort" "value"
redirect $ TodolistItemsR groupId todolistId

6
stack.yaml
View file

@ -20,10 +20,6 @@
snapshot:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/26.yaml
nix:
enable: true
pure: false
# User packages to be built.
# Various formats can be used as shown in the example below.
#
@ -53,7 +49,7 @@ packages:
# extra-package-dbs: []
# 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-stack-version: -any # Default

2
stack.yaml.lock
View file

@ -1,7 +1,7 @@
# This file was autogenerated by Stack.
# You should not edit this file by hand.
# 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: []
snapshots:

3
templates/default-layout.hamlet
View file

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

2
templates/edit-group.hamlet
View file

@ -5,4 +5,4 @@
<input type="checkbox" name="ids" value="#{a group}">
<a href="">#{(groupGroup . entityVal) group}
<button type=submit>Delete selected
<a href=@{GroupR}>Back
<a href=@{GroupR}>Back

2
templates/edit-todolist.hamlet
View file

@ -5,4 +5,4 @@
<input type="checkbox" name="ids" value="#{keyToText list}">
<a href="">#{(todolistTitle . entityVal) list}
<button type=submit>Delete selected
<a href=@{TodolistR groupId}>Back
<a href=@{TodolistR groupId}>Back

6
templates/group.hamlet
View file

@ -1,9 +1,9 @@
<a href=@{GroupR}>Home
<ul>
<ul>
$forall group <- groups
<li>
<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">
<button type="submit">add
<a href=@{EditGroupR}>Edit
<a href=@{EditGroupR}>Edit

141
templates/homepage.hamlet
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>

34
templates/homepage.julius
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);
},
});
});
});

13
templates/homepage.lucius
View file

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

10
templates/profile.hamlet
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>!

14
templates/todolist-items.hamlet
View file

@ -1,17 +1,17 @@
<a href=@{GroupR}>Home
&nbsp;
<a href=@{TodolistR groupId}>Lists
<ul>
&nbsp;
<a href=@{TodolistR groupId}>Lists
<ul>
$forall item <- items
<li>
<form action=@{CheckTodolistItemR groupId todolistId (entityKey item)} method="POST">
<button type="submit">#{getText item}
<form action=@{AddTodolistItemR groupId todolistId} method="post">
<form action=@{AddTodolistItemR groupId todolistId} method="post">
<form action=@{AddTodolistItemR groupId todolistId} method="post">
<input type="text" name="item" placeholder="new item">
<button type="submit">add
<form action=@{TrimTodolistItemsR groupId todolistId} method="post">
<form action=@{TrimTodolistItemsR groupId todolistId} method="post">
<button type="submit">trim
<form action=@{SortTodolistItemsR groupId todolistId} method="post">
<form action=@{SortTodolistItemsR groupId todolistId} method="post">
<button type="submit">sort
<a href=@{EditTodolistItemsR groupId todolistId}>Edit
<a href=@{EditTodolistItemsR groupId todolistId}>Edit

8
templates/todolist.hamlet
View file

@ -1,12 +1,12 @@
<a href=@{GroupR}>Home
<ul>
<ul>
$forall list <- lists
<li>
<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">
<button type="submit">add
<form action=@{AddUserR groupId} method="post">
<form action=@{AddUserR groupId} method="post">
<input type="text" name="user" placeholder="new user">
<button type="submit">share
<a href=@{EditTodolistR groupId}>Edit
<a href=@{EditTodolistR groupId}>Edit