diff --git a/README.md b/README.md index 8f8616b..f959a93 100644 --- a/README.md +++ b/README.md @@ -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) diff --git a/config/models.persistentmodels b/config/models.persistentmodels index d9a31b5..07df491 100644 --- a/config/models.persistentmodels +++ b/config/models.persistentmodels @@ -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 \ No newline at end of file + groupId GroupId OnDeleteCascade diff --git a/src/Foundation.hs b/src/Foundation.hs index bdd1015..98ad0e6 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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] \ No newline at end of file + let sql = "SELECT ?? FROM \"group\" JOIN group_user gu ON \"group\".id = gu.group_id WHERE gu.user = ?" + in runDB $ rawSql sql [toPersistValue userId] diff --git a/src/Handler/Api.hs b/src/Handler/Api.hs index f429a0e..c1be3d8 100644 --- a/src/Handler/Api.hs +++ b/src/Handler/Api.hs @@ -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" \ No newline at end of file + -- 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" diff --git a/src/Handler/Group.hs b/src/Handler/Group.hs index eb15bea..6c76734 100644 --- a/src/Handler/Group.hs +++ b/src/Handler/Group.hs @@ -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 \ No newline at end of file + 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 diff --git a/src/Handler/Todolist.hs b/src/Handler/Todolist.hs index 1520130..c145309 100644 --- a/src/Handler/Todolist.hs +++ b/src/Handler/Todolist.hs @@ -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 \ No newline at end of file + ) + redirect $ TodolistR groupId diff --git a/src/Handler/TodolistItem.hs b/src/Handler/TodolistItem.hs index 9340ff9..4dc8f7a 100644 --- a/src/Handler/TodolistItem.hs +++ b/src/Handler/TodolistItem.hs @@ -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 \ No newline at end of file +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 diff --git a/stack.yaml b/stack.yaml index 3092e82..377bf75 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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 diff --git a/stack.yaml.lock b/stack.yaml.lock index 7b81abd..eef24df 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -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: diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index f18fd65..2ef168a 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -1,11 +1,10 @@
- $maybe msg <- mmsg -
#{msg} - -^{widget} + $maybe msg <- mmsg +
#{msg} + ^{widget}