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 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
|
||||
|
||||
1. If you haven't already, [install Stack](https://haskell-lang.org/get-started)
|
||||
|
|
|
|||
|
|
@ -10,13 +10,13 @@ Todolist
|
|||
title Text
|
||||
lastModified UTCTime
|
||||
UniqueListPair groupId title
|
||||
deriving Show
|
||||
User
|
||||
name Text
|
||||
lastModified UTCTime
|
||||
UniqueName name
|
||||
Group
|
||||
group Text
|
||||
lastModified UTCTime
|
||||
GroupUser
|
||||
user UserId
|
||||
groupId GroupId OnDeleteCascade
|
||||
groupId GroupId OnDeleteCascade
|
||||
|
|
|
|||
|
|
@ -1,47 +1,51 @@
|
|||
{-# 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 Data.Kind (Type)
|
||||
import Database.Persist.Sql (ConnectionPool, runSqlPool, rawSql)
|
||||
import Text.Hamlet (hamletFile)
|
||||
import Text.Jasmine (minifym)
|
||||
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 qualified Yesod.Core.Unsafe as Unsafe
|
||||
import Yesod.Core.Types (Logger)
|
||||
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.
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: Logger
|
||||
}
|
||||
{ appSettings :: AppSettings
|
||||
, appStatic :: Static
|
||||
-- ^ Settings for static file serving.
|
||||
, appConnPool :: ConnectionPool
|
||||
-- ^ Database connection pool.
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: Logger
|
||||
}
|
||||
|
||||
data MenuItem = MenuItem
|
||||
{ menuItemLabel :: Text
|
||||
, menuItemRoute :: Route App
|
||||
, menuItemAccessCallback :: Bool
|
||||
}
|
||||
{ menuItemLabel :: Text
|
||||
, menuItemRoute :: Route App
|
||||
, menuItemAccessCallback :: Bool
|
||||
}
|
||||
|
||||
data MenuTypes
|
||||
= NavbarLeft MenuItem
|
||||
| NavbarRight MenuItem
|
||||
= NavbarLeft MenuItem
|
||||
| NavbarRight MenuItem
|
||||
|
||||
-- This is where we define all of the routes in our application. For a full
|
||||
-- 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)
|
||||
|
||||
-- | 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.
|
||||
instance Yesod App where
|
||||
-- Controls the base of generated URLs. For more information on modifying,
|
||||
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
|
||||
approot :: Approot App
|
||||
approot = ApprootRequest $ \app req ->
|
||||
case appRoot $ appSettings app of
|
||||
Nothing -> getApprootText guessApproot app req
|
||||
Just root -> root
|
||||
-- Controls the base of generated URLs. For more information on modifying,
|
||||
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
|
||||
approot :: Approot App
|
||||
approot = ApprootRequest $ \app req ->
|
||||
case appRoot $ appSettings app of
|
||||
Nothing -> getApprootText guessApproot app req
|
||||
Just root -> root
|
||||
|
||||
-- -- Store session data on the client in encrypted cookies,
|
||||
-- -- default session idle timeout is 120 minutes
|
||||
-- makeSessionBackend :: App -> IO (Maybe SessionBackend)
|
||||
-- makeSessionBackend app = Just <$> defaultClientSessionBackend
|
||||
-- 120 -- timeout in minutes
|
||||
-- (appSessionKey $ appSettings app)
|
||||
-- -- Store session data on the client in encrypted cookies,
|
||||
-- -- default session idle timeout is 120 minutes
|
||||
-- makeSessionBackend :: App -> IO (Maybe SessionBackend)
|
||||
-- makeSessionBackend app = Just <$> defaultClientSessionBackend
|
||||
-- 120 -- timeout in minutes
|
||||
-- (appSessionKey $ appSettings app)
|
||||
|
||||
-- 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.
|
||||
-- Some users may also want to add the defaultCsrfMiddleware, which:
|
||||
-- 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.
|
||||
-- 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.
|
||||
-- yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
|
||||
-- yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
||||
-- 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.
|
||||
-- Some users may also want to add the defaultCsrfMiddleware, which:
|
||||
-- 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.
|
||||
-- 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.
|
||||
-- yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
|
||||
-- yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
|
||||
|
||||
defaultLayout :: Widget -> Handler Html
|
||||
defaultLayout widget = do
|
||||
master <- getYesod
|
||||
mmsg <- getMessage
|
||||
defaultLayout :: Widget -> Handler Html
|
||||
defaultLayout widget = do
|
||||
master <- getYesod
|
||||
mmsg <- getMessage
|
||||
|
||||
-- mcurrentRoute <- getCurrentRoute
|
||||
-- mcurrentRoute <- getCurrentRoute
|
||||
|
||||
-- We break up the default layout into two components:
|
||||
-- default-layout is the contents of the body tag, and
|
||||
-- default-layout-wrapper is the entire page. Since the final
|
||||
-- value passed to hamletToRepHtml cannot be a widget, this allows
|
||||
-- you to use normal widget features in default-layout.
|
||||
-- We break up the default layout into two components:
|
||||
-- default-layout is the contents of the body tag, and
|
||||
-- default-layout-wrapper is the entire page. Since the final
|
||||
-- value passed to hamletToRepHtml cannot be a widget, this allows
|
||||
-- you to use normal widget features in default-layout.
|
||||
|
||||
pc <- widgetToPageContent $ do
|
||||
$(widgetFile "default-layout")
|
||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
pc <- widgetToPageContent $ do
|
||||
$(widgetFile "default-layout")
|
||||
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
|
||||
|
||||
-- isAuthorized
|
||||
-- :: Route App -- ^ The route the user is visiting.
|
||||
-- -> Bool -- ^ Whether or not this is a "write" request.
|
||||
-- -> Handler AuthResult
|
||||
-- -- Routes not requiring authentication.
|
||||
-- isAuthorized _ _ = return Authorized
|
||||
-- isAuthorized
|
||||
-- :: Route App -- ^ The route the user is visiting.
|
||||
-- -> Bool -- ^ Whether or not this is a "write" request.
|
||||
-- -> Handler AuthResult
|
||||
-- -- 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 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
|
||||
-- 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
|
||||
-- What messages should be logged. The following includes all messages when
|
||||
-- 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
|
||||
|
||||
-- What messages should be logged. The following includes all messages when
|
||||
-- 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
|
||||
|
||||
makeLogger :: App -> IO Logger
|
||||
makeLogger = return . appLogger
|
||||
makeLogger :: App -> IO Logger
|
||||
makeLogger = return . appLogger
|
||||
|
||||
-- How to run database actions.
|
||||
instance YesodPersist App where
|
||||
type YesodPersistBackend App = SqlBackend
|
||||
runDB :: SqlPersistT Handler a -> Handler a
|
||||
runDB action = do
|
||||
master <- getYesod
|
||||
runSqlPool action $ appConnPool master
|
||||
type YesodPersistBackend App = SqlBackend
|
||||
runDB :: SqlPersistT Handler a -> Handler a
|
||||
runDB action = do
|
||||
master <- getYesod
|
||||
runSqlPool action $ appConnPool master
|
||||
|
||||
instance YesodPersistRunner App where
|
||||
getDBRunner :: Handler (DBRunner App, Handler ())
|
||||
getDBRunner = defaultGetDBRunner appConnPool
|
||||
getDBRunner :: Handler (DBRunner App, Handler ())
|
||||
getDBRunner = defaultGetDBRunner appConnPool
|
||||
|
||||
-- This instance is required to use forms. You can modify renderMessage to
|
||||
-- achieve customized and internationalized form validation messages.
|
||||
instance RenderMessage App FormMessage where
|
||||
renderMessage :: App -> [Lang] -> FormMessage -> Text
|
||||
renderMessage _ _ = defaultFormMessage
|
||||
renderMessage :: App -> [Lang] -> FormMessage -> Text
|
||||
renderMessage _ _ = defaultFormMessage
|
||||
|
||||
-- Useful when writing code that is re-usable outside of the Handler context.
|
||||
-- An example is background jobs that send email.
|
||||
-- This can also be useful for writing code that works across multiple Yesod applications.
|
||||
instance HasHttpManager App where
|
||||
getHttpManager :: App -> Manager
|
||||
getHttpManager = appHttpManager
|
||||
getHttpManager :: App -> Manager
|
||||
getHttpManager = appHttpManager
|
||||
|
||||
unsafeHandler :: App -> Handler a -> IO a
|
||||
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/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"
|
||||
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"
|
||||
case mUser of
|
||||
Left (Entity userId _) -> return userId
|
||||
Right userId -> return userId
|
||||
mName <- lookupHeader "Remote-User"
|
||||
currentTime <- liftIO getCurrentTime
|
||||
mUser <- case mName of
|
||||
-- TODO: make remote user an argument to make it usable not only with authelia, and maybe do a check for good mesure when nothing is found ?
|
||||
Just name -> runDB $ insertBy $ User (decodeUtf8 name) currentTime
|
||||
Nothing -> runDB $ insertBy $ User "single-user" currentTime
|
||||
case mUser of
|
||||
Left (Entity userId _) -> return userId
|
||||
Right userId -> return userId
|
||||
|
||||
dbIfAuth :: GroupId -> ReaderT SqlBackend (HandlerFor App) b -> HandlerFor App b
|
||||
dbIfAuth groupId action = do
|
||||
-- TODO: decide if we prefer fast (rawSql) or safe (type safe persist query) after in production latency tests
|
||||
user <- getUserId
|
||||
result <- runDB $ selectFirst [GroupUserUser ==. user, GroupUserGroupId ==. groupId] []
|
||||
if isNothing result then permissionDenied "you are not logged in or you dont have access to this group"
|
||||
-- TODO: decide if we prefer fast (rawSql) or safe (type safe persist query) after in production latency tests
|
||||
user <- getUserId
|
||||
result <- runDB $ selectFirst [GroupUserUser ==. user, GroupUserGroupId ==. groupId] []
|
||||
if isNothing result
|
||||
then permissionDenied "you are not logged in or you dont have access to this group"
|
||||
else runDB action
|
||||
|
||||
getGroups :: Key User -> Handler [Entity Group]
|
||||
getGroups userId =
|
||||
let sql = "SELECT ?? FROM \"group\" JOIN group_user gu ON \"group\".id = gu.group_id WHERE gu.user = ?" in
|
||||
runDB $ rawSql sql [toPersistValue userId]
|
||||
let sql = "SELECT ?? FROM \"group\" JOIN group_user gu ON \"group\".id = gu.group_id WHERE gu.user = ?"
|
||||
in runDB $ rawSql sql [toPersistValue userId]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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
|
||||
-- TODO: use only one runDB (or use joins ?)
|
||||
userId <- getUserId
|
||||
let utcTime = posixSecondsToUTCTime (fromIntegral time)
|
||||
-- condition : parent user or group changed
|
||||
let sqlUpdatedGroups = "select ?? from \"group\" join group_user gu on \"group\".id = gu.group_id where gu.user = ? where \"group\".last_modified > ? or user.last_modified > ?;"
|
||||
-- condition : parent group or list changed
|
||||
let sqlUpdatedLists = "select ?? from todolist join group_user on todolist.group_id = group_user.group_id and group_user.user = ? join \"group\" as g on g.id = todolist.id where list.last_modified > ? or g.last_modified > ?;"
|
||||
-- condition : parent list changed
|
||||
let sqlUpdatedItems = "select ?? from todolist where todolist.last_modified > ? join group_user on todolist.group_id = group_user.group_id and group_user.user = ? join todolist_item on todolist_item.todolist_id = todolist.id;"
|
||||
runDB $ do
|
||||
user <- selectList [UserId ==. userId, UserLastModified >. utcTime] []
|
||||
groups <- rawSql sqlUpdatedGroups [toPersistValue userId, toPersistValue utcTime, toPersistValue utcTime]
|
||||
lists <- rawSql sqlUpdatedLists [toPersistValue userId, toPersistValue utcTime, toPersistValue utcTime]
|
||||
items <- rawSql sqlUpdatedItems [toPersistValue utcTime, toPersistValue userId]
|
||||
let t =
|
||||
unlines
|
||||
$ map userToCSV user
|
||||
<> map groupToCSV groups
|
||||
<> map todolistToCSV lists
|
||||
<> map todolistItemToCSV items
|
||||
return $ TypedContent typePlain $ toContent t
|
||||
|
||||
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
|
||||
|
|
@ -38,15 +51,15 @@ persistValueToText (PersistText s) = s
|
|||
persistValueToText (PersistInt64 i) = Text.pack $ show i
|
||||
persistValueToText (PersistUTCTime d) = Text.pack $ show $ floor (utcTimeToPOSIXSeconds d)
|
||||
persistValueToText (PersistBool b) = if b then "T" else "F"
|
||||
persistValueToText _ = error "Wrong input type"
|
||||
persistValueToText _ = error "Wrong input type"
|
||||
|
||||
getText :: Text
|
||||
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 ITEM FROM THESE TODOLISTS
|
||||
-- ENCODE ALL OF THEM IN THE TEXTFILE
|
||||
-- SEND IT !
|
||||
-- DONE :)
|
||||
error "not done yet"
|
||||
-- GET EVERY TODOLIST THAT HAS BEEN MODIFIED SINCE TIMESTAMP
|
||||
-- GET EVERY ITEM FROM THESE TODOLISTS
|
||||
-- ENCODE ALL OF THEM IN THE TEXTFILE
|
||||
-- SEND IT !
|
||||
-- DONE :)
|
||||
error "not done yet"
|
||||
|
|
|
|||
|
|
@ -1,58 +1,68 @@
|
|||
{-# 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
|
||||
groups <- getGroups userId
|
||||
defaultLayout $ do
|
||||
setTitle "Groups"
|
||||
$(widgetFile "group")
|
||||
userId <- getUserId
|
||||
groups <- getGroups userId
|
||||
defaultLayout $ do
|
||||
setTitle "Groups"
|
||||
$(widgetFile "group")
|
||||
postAddGroupR :: Handler Html
|
||||
postAddGroupR = do
|
||||
g <- runInputPost $ ireq textField "group"
|
||||
-- TODO: in a newer version, put insertUnique_
|
||||
user <- getUserId
|
||||
_ <- runDB $ do
|
||||
currentTime <- liftIO getCurrentTime
|
||||
gId <- insert $ Group g currentTime
|
||||
success <- insertUnique $ GroupUser user gId
|
||||
when (isNothing success) $ delete gId
|
||||
redirect GroupR
|
||||
g <- runInputPost $ ireq textField "group"
|
||||
-- TODO: in a newer version, put insertUnique_
|
||||
user <- getUserId
|
||||
_ <- runDB $ do
|
||||
currentTime <- liftIO getCurrentTime
|
||||
gId <- insert $ Group g currentTime
|
||||
success <- insertUnique $ GroupUser user gId
|
||||
when (isNothing success) $ delete gId
|
||||
redirect GroupR
|
||||
|
||||
getEditGroupR :: Handler Html
|
||||
getEditGroupR = do
|
||||
userId <- getUserId
|
||||
groups <- getGroups userId
|
||||
defaultLayout $ do
|
||||
let a e = pack $ show $ fromSqlKey $ entityKey e ::Text
|
||||
setTitle "Groups"
|
||||
$(widgetFile "edit-group")
|
||||
userId <- getUserId
|
||||
groups <- getGroups userId
|
||||
defaultLayout $ do
|
||||
let a e = pack $ show $ fromSqlKey $ entityKey e :: Text
|
||||
setTitle "Groups"
|
||||
$(widgetFile "edit-group")
|
||||
postEditGroupR :: Handler Html
|
||||
postEditGroupR = do
|
||||
-- TODO: not implemented yet
|
||||
-- title <- runInputPost $ ireq textField "title"
|
||||
-- users <- runInputPost $ ireq textField "users"
|
||||
-- id <- runInputPost $ ireq intField "id"
|
||||
-- let key = toSqlKey id
|
||||
-- runDB $ update key [GroupGroup =. title]
|
||||
redirect EditGroupR
|
||||
-- TODO: not implemented yet
|
||||
-- title <- runInputPost $ ireq textField "title"
|
||||
-- users <- runInputPost $ ireq textField "users"
|
||||
-- id <- runInputPost $ ireq intField "id"
|
||||
-- let key = toSqlKey id
|
||||
-- runDB $ update key [GroupGroup =. title]
|
||||
redirect EditGroupR
|
||||
postDeleteGroupR :: Handler Html
|
||||
postDeleteGroupR = do
|
||||
text <- lookupPostParams "ids"
|
||||
let ints = map (read . unpack) text :: [Int64]
|
||||
let ids = map toSqlKey ints :: [GroupId]
|
||||
-- TODO: make sure the user has access to it aswell (this only works now for single user), and handle group owned by many
|
||||
runDB $ deleteWhere [GroupId <-. ids]
|
||||
redirect EditGroupR
|
||||
text <- lookupPostParams "ids"
|
||||
let ints = map (read . unpack) text :: [Int64]
|
||||
let ids = map toSqlKey ints :: [GroupId]
|
||||
userId <- getUserId
|
||||
currentTime <- liftIO getCurrentTime
|
||||
-- TODO: test this and maybe change it to sql to be more efficient ?
|
||||
when (ids /= [])
|
||||
$ runDB
|
||||
$ do
|
||||
update userId [UserLastModified =. currentTime]
|
||||
deleteWhere [GroupUserGroupId <-. ids, GroupUserUser ==. userId]
|
||||
nonOrphans <- selectList [GroupUserGroupId <-. ids] []
|
||||
let nonOrphansIds = map (groupUserGroupId . entityVal) nonOrphans
|
||||
deleteWhere [GroupId <-. ids, GroupId /<-. nonOrphansIds]
|
||||
redirect EditGroupR
|
||||
|
|
|
|||
|
|
@ -1,61 +1,74 @@
|
|||
{-# 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"
|
||||
-- TODO: in a newer version, put insertUnique_
|
||||
currentTime <- liftIO getCurrentTime
|
||||
_ <- dbIfAuth groupId (insertUnique $ Todolist groupId list currentTime)
|
||||
redirect $ TodolistR groupId
|
||||
list <- runInputPost $ ireq textField "list"
|
||||
-- TODO: in a newer version, put insertUnique_
|
||||
currentTime <- liftIO getCurrentTime
|
||||
_ <- dbIfAuth groupId (insertUnique $ Todolist groupId list currentTime)
|
||||
redirect $ TodolistR groupId
|
||||
|
||||
-- TODO: move this to a new handler file
|
||||
getTodolistR :: GroupId -> Handler Html
|
||||
getTodolistR groupId = do
|
||||
lists <- dbIfAuth groupId (selectList [TodolistGroupId ==. groupId] [])
|
||||
defaultLayout $ do
|
||||
let getTitle = todolistTitle . entityVal
|
||||
setTitle "todolist"
|
||||
$(widgetFile "todolist")
|
||||
lists <- dbIfAuth groupId (selectList [TodolistGroupId ==. groupId] [])
|
||||
defaultLayout $ do
|
||||
let getTitle = todolistTitle . entityVal
|
||||
setTitle "todolist"
|
||||
$(widgetFile "todolist")
|
||||
|
||||
getEditTodolistR :: GroupId -> Handler Html
|
||||
getEditTodolistR groupId = do
|
||||
lists <- runDB $
|
||||
selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
|
||||
defaultLayout $ do
|
||||
let keyToText e = pack $ show $ fromSqlKey $ entityKey e ::Text
|
||||
setTitle "Groups"
|
||||
$(widgetFile "edit-todolist")
|
||||
lists <-
|
||||
runDB
|
||||
$ selectList [TodolistGroupId ==. groupId] [Asc TodolistTitle]
|
||||
defaultLayout $ do
|
||||
let keyToText e = pack $ show $ fromSqlKey $ entityKey e :: Text
|
||||
setTitle "Groups"
|
||||
$(widgetFile "edit-todolist")
|
||||
|
||||
postDeleteTodolistR :: GroupId -> Handler Html
|
||||
postDeleteTodolistR groupId = do
|
||||
text <- lookupPostParams "ids"
|
||||
let ints = map (read . unpack) text :: [Int64]
|
||||
let ids = map toSqlKey ints :: [TodolistId]
|
||||
dbIfAuth groupId (deleteWhere [TodolistId <-. ids])
|
||||
redirect $ EditTodolistR groupId
|
||||
text <- lookupPostParams "ids"
|
||||
currentTime <- liftIO getCurrentTime
|
||||
let ints = map (read . unpack) text :: [Int64]
|
||||
let ids = map toSqlKey ints :: [TodolistId]
|
||||
dbIfAuth
|
||||
groupId
|
||||
( do
|
||||
deleteWhere [TodolistId <-. ids]
|
||||
update groupId [GroupLastModified =. currentTime]
|
||||
)
|
||||
|
||||
redirect $ EditTodolistR groupId
|
||||
postEditTodolistR :: GroupId -> Handler Html
|
||||
postEditTodolistR groupId = error "not done yet"
|
||||
|
||||
postAddUserR :: GroupId -> Handler Html
|
||||
postAddUserR groupId= do
|
||||
user <- runInputPost $ ireq textField "user"
|
||||
_ <- dbIfAuth groupId (do
|
||||
mUserId <- getBy $ UniqueName user
|
||||
case mUserId of
|
||||
Nothing -> --handle error
|
||||
redirect $ TodolistR groupId
|
||||
postAddUserR groupId = do
|
||||
user <- runInputPost $ ireq textField "user"
|
||||
_ <-
|
||||
dbIfAuth
|
||||
groupId
|
||||
( do
|
||||
mUserId <- getBy $ UniqueName user
|
||||
case mUserId of
|
||||
Nothing ->
|
||||
-- handle error
|
||||
redirect $ TodolistR groupId
|
||||
Just userId -> insert $ GroupUser (entityKey userId) groupId
|
||||
)
|
||||
redirect $ TodolistR groupId
|
||||
)
|
||||
redirect $ TodolistR groupId
|
||||
|
|
|
|||
|
|
@ -1,91 +1,117 @@
|
|||
{-# 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
|
||||
mSortOption <- lookupSession "sort"
|
||||
items <- case mSortOption of
|
||||
(Just "value") -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Desc TodolistItemValue, Asc TodolistItemId])
|
||||
_ -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Asc TodolistItemId])
|
||||
|
||||
defaultLayout $ do
|
||||
setTitle "items"
|
||||
$(widgetFile "todolist-items")
|
||||
mSortOption <- lookupSession "sort"
|
||||
items <- case mSortOption of
|
||||
(Just "value") -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Desc TodolistItemValue, Asc TodolistItemId])
|
||||
_ -> dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [Asc TodolistItemId])
|
||||
|
||||
defaultLayout $ 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])
|
||||
redirect $ TodolistItemsR groupId todolistId
|
||||
|
||||
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
|
||||
item <- runInputPost $ ireq textField "item"
|
||||
_ <- dbIfAuth groupId (insert_ $ TodolistItem todolistId False item)
|
||||
redirect $ TodolistItemsR groupId todolistId
|
||||
currentTime <- liftIO getCurrentTime
|
||||
item <- runInputPost $ ireq textField "item"
|
||||
_ <-
|
||||
dbIfAuth
|
||||
groupId
|
||||
( do
|
||||
insert_ $ TodolistItem todolistId False item
|
||||
update todolistId [TodolistLastModified =. currentTime]
|
||||
)
|
||||
redirect $ TodolistItemsR groupId todolistId
|
||||
|
||||
getEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||
getEditTodolistItemsR groupId todolistId = do
|
||||
items <- dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [])
|
||||
let text = unlines $ map getText items
|
||||
defaultLayout $ do
|
||||
setTitle "edit"
|
||||
$(widgetFile "edit-todolist-items")
|
||||
|
||||
items <- dbIfAuth groupId (selectList [TodolistItemTodolistId ==. todolistId] [])
|
||||
let text = unlines $ map getText items
|
||||
defaultLayout $ do
|
||||
setTitle "edit"
|
||||
$(widgetFile "edit-todolist-items")
|
||||
|
||||
postEditTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||
postEditTodolistItemsR groupId todolistId = do
|
||||
mText <- runInputPost $ iopt textField "text"
|
||||
let xs = case mText of
|
||||
(Just text) -> getItems text todolistId
|
||||
Nothing -> []
|
||||
dbIfAuth groupId (do
|
||||
currentTime <- liftIO getCurrentTime
|
||||
mText <- runInputPost $ iopt textField "text"
|
||||
let xs = case mText of
|
||||
(Just text) -> getItems text todolistId
|
||||
Nothing -> [] -- Case statement used to let delete all without error TODO: check if can use flatmap instead ?
|
||||
dbIfAuth
|
||||
groupId
|
||||
( do
|
||||
deleteWhere [TodolistItemTodolistId ==. todolistId]
|
||||
insertMany_ xs)
|
||||
|
||||
redirect $ TodolistItemsR groupId todolistId
|
||||
insertMany_ xs
|
||||
update todolistId [TodolistLastModified =. currentTime]
|
||||
)
|
||||
|
||||
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
|
||||
redirect $ TodolistItemsR groupId todolistId
|
||||
|
||||
postTrimTodolistItemsR :: GroupId -> TodolistId -> Handler Html
|
||||
postTrimTodolistItemsR groupId todolistId = do
|
||||
dbIfAuth groupId (deleteWhere [TodolistItemTodolistId ==. todolistId, TodolistItemValue ==. True])
|
||||
redirect $ TodolistItemsR groupId todolistId
|
||||
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
|
||||
postSortTodolistItemsR groupId todolistId = do
|
||||
mSession <- lookupSession "sort"
|
||||
case mSession of
|
||||
(Just "value") -> setSession "sort" "id"
|
||||
_ -> setSession "sort" "value"
|
||||
redirect $ TodolistItemsR groupId todolistId
|
||||
|
||||
getText :: Entity TodolistItem -> Text
|
||||
getText item =
|
||||
if value
|
||||
then "[x] " <> name
|
||||
else "[ ] " <> name
|
||||
where
|
||||
value = (todolistItemValue . entityVal) item
|
||||
name = (todolistItemName . entityVal) item
|
||||
|
||||
getItems :: Text -> TodolistId -> [TodolistItem]
|
||||
getItems text todolistId = map read (lines text)
|
||||
where
|
||||
read line = do
|
||||
let (d, n) = splitAt 4 line
|
||||
let
|
||||
value = case d of
|
||||
"[x] " -> True
|
||||
"[ ] " -> False
|
||||
_ -> error "Invalid status"
|
||||
name = case n of
|
||||
"" -> error "empty name"
|
||||
something -> filter (/= '\r') something
|
||||
TodolistItem todolistId value name
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
<!-- Page Contents -->
|
||||
<div .container>
|
||||
$maybe msg <- mmsg
|
||||
<div>#{msg}
|
||||
|
||||
^{widget}
|
||||
$maybe msg <- mmsg
|
||||
<div>#{msg}
|
||||
^{widget}
|
||||
|
||||
<!-- Footer -->
|
||||
<footer>
|
||||
<p>
|
||||
#{appCopyright $ appSettings master}
|
||||
<p>
|
||||
#{appCopyright $ appSettings master}
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
<form action=@{DeleteGroupR} method="POST">
|
||||
<ul>
|
||||
$forall group <- groups
|
||||
<li>
|
||||
<input type="checkbox" name="ids" value="#{a group}">
|
||||
<a href="">#{(groupGroup . entityVal) group}
|
||||
<button type=submit>Delete selected
|
||||
<a href=@{GroupR}>Back
|
||||
<ul>
|
||||
$forall group <- groups
|
||||
<li>
|
||||
<input type="checkbox" name="ids" value="#{a group}">
|
||||
<a href="">#{(groupGroup . entityVal) group}
|
||||
<button type=submit>Delete selected
|
||||
<a href=@{GroupR}>Back
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
<form action=@{EditTodolistItemsR groupId todolistId} method=POST>
|
||||
<label for="edit text area">Edit todolist
|
||||
<br>
|
||||
<textarea id="edit text area" name=text rows=30 cols=50 placeholder="[x] wake up1 [x] eat [ ] sleep [ ] repeat">#{text}
|
||||
<br>
|
||||
<button type="submit">edit
|
||||
<label for="edit text area">Edit todolist
|
||||
<br>
|
||||
<textarea id="edit text area" name=text rows=30 cols=50 placeholder="[x] wake up1 [x] eat [ ] sleep [ ] repeat">#{text}
|
||||
<br>
|
||||
<button type="submit">edit
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
<form action=@{DeleteTodolistR groupId} method="POST">
|
||||
<ul>
|
||||
$forall list <- lists
|
||||
<li>
|
||||
<input type="checkbox" name="ids" value="#{keyToText list}">
|
||||
<a href="">#{(todolistTitle . entityVal) list}
|
||||
<button type=submit>Delete selected
|
||||
<a href=@{TodolistR groupId}>Back
|
||||
<ul>
|
||||
$forall list <- lists
|
||||
<li>
|
||||
<input type="checkbox" name="ids" value="#{keyToText list}">
|
||||
<a href="">#{(todolistTitle . entityVal) list}
|
||||
<button type=submit>Delete selected
|
||||
<a href=@{TodolistR groupId}>Back
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
<a href=@{GroupR}>Home
|
||||
<ul>
|
||||
$forall group <- groups
|
||||
<li>
|
||||
<a href=@{TodolistR $ entityKey group}>#{(groupGroup . entityVal) group}
|
||||
<form action=@{AddGroupR} method="post">
|
||||
<input type="text" name="group" placeholder="new group">
|
||||
<button type="submit">add
|
||||
<a href=@{EditGroupR}>Edit
|
||||
<ul>
|
||||
$forall group <- groups
|
||||
<li>
|
||||
<a href=@{TodolistR $ entityKey group}>#{(groupGroup . entityVal) group}
|
||||
<form action=@{AddGroupR} method="post">
|
||||
<input type="text" name="group" placeholder="new group">
|
||||
<button type="submit">add
|
||||
<a href=@{EditGroupR}>Edit
|
||||
|
|
|
|||
|
|
@ -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=@{TodolistR groupId}>Lists
|
||||
<ul>
|
||||
$forall item <- items
|
||||
<li>
|
||||
<form action=@{CheckTodolistItemR groupId todolistId (entityKey item)} method="POST">
|
||||
<button type="submit">#{getText item}
|
||||
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
||||
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
||||
<input type="text" name="item" placeholder="new item">
|
||||
<button type="submit">add
|
||||
<form action=@{TrimTodolistItemsR groupId todolistId} method="post">
|
||||
<button type="submit">trim
|
||||
<form action=@{SortTodolistItemsR groupId todolistId} method="post">
|
||||
<button type="submit">sort
|
||||
<a href=@{EditTodolistItemsR groupId todolistId}>Edit
|
||||
|
||||
<a href=@{TodolistR groupId}>Lists
|
||||
<ul>
|
||||
$forall item <- items
|
||||
<li>
|
||||
<form action=@{CheckTodolistItemR groupId todolistId (entityKey item)} method="POST">
|
||||
<button type="submit">#{getText item}
|
||||
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
||||
<form action=@{AddTodolistItemR groupId todolistId} method="post">
|
||||
<input type="text" name="item" placeholder="new item">
|
||||
<button type="submit">add
|
||||
<form action=@{TrimTodolistItemsR groupId todolistId} method="post">
|
||||
<button type="submit">trim
|
||||
<form action=@{SortTodolistItemsR groupId todolistId} method="post">
|
||||
<button type="submit">sort
|
||||
<a href=@{EditTodolistItemsR groupId todolistId}>Edit
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
<a href=@{GroupR}>Home
|
||||
<ul>
|
||||
$forall list <- lists
|
||||
<li>
|
||||
<a href=@{TodolistItemsR groupId (entityKey list)}>#{getTitle list}
|
||||
<form action=@{AddTodolistR groupId} method="post">
|
||||
<input type="text" name="list" placeholder="new list">
|
||||
<button type="submit">add
|
||||
<form action=@{AddUserR groupId} method="post">
|
||||
<input type="text" name="user" placeholder="new user">
|
||||
<button type="submit">share
|
||||
<a href=@{EditTodolistR groupId}>Edit
|
||||
<ul>
|
||||
$forall list <- lists
|
||||
<li>
|
||||
<a href=@{TodolistItemsR groupId (entityKey list)}>#{getTitle list}
|
||||
<form action=@{AddTodolistR groupId} method="post">
|
||||
<input type="text" name="list" placeholder="new list">
|
||||
<button type="submit">add
|
||||
<form action=@{AddUserR groupId} method="post">
|
||||
<input type="text" name="user" placeholder="new user">
|
||||
<button type="submit">share
|
||||
<a href=@{EditTodolistR groupId}>Edit
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue