diff --git a/README.md b/README.md index 5b27657..98b93f1 100644 --- a/README.md +++ b/README.md @@ -10,18 +10,16 @@ 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 groups that contain a list of todolists + - add and delete (and soon share) 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) diff --git a/config/models.persistentmodels b/config/models.persistentmodels index 07df491..d9a31b5 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 + groupId GroupId OnDeleteCascade \ No newline at end of file diff --git a/src/Foundation.hs b/src/Foundation.hs index 98ad0e6..bdd1015 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,51 +1,47 @@ -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE InstanceSigs #-} module Foundation where -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 Data.Kind (Type) +import Database.Persist.Sql (ConnectionPool, runSqlPool, rawSql) +import Text.Hamlet (hamletFile) +import Text.Jasmine (minifym) +import Control.Monad.Logger (LogSource) -import Yesod.Core.Types (Logger) -import Yesod.Core.Unsafe qualified as Unsafe -import Yesod.Default.Util (addStaticContentExternal) +import Yesod.Default.Util (addStaticContentExternal) +import Yesod.Core.Types (Logger) +import qualified Yesod.Core.Unsafe as Unsafe -{- | 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: @@ -65,128 +61,122 @@ 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 - -- 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 + -- 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 - makeLogger :: App -> IO Logger - makeLogger = return . appLogger + -- 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 -- 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 @@ -199,29 +189,28 @@ 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) currentTime - Nothing -> runDB $ insertBy $ User "single-user" currentTime - case mUser of - Left (Entity userId _) -> return userId - Right userId -> return userId + 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 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] \ No newline at end of file diff --git a/src/Handler/Api.hs b/src/Handler/Api.hs index c1be3d8..f429a0e 100644 --- a/src/Handler/Api.hs +++ b/src/Handler/Api.hs @@ -1,36 +1,25 @@ -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Handler.Api where -import Data.Text qualified as Text -import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) -import Database.Persist.Sql (rawSql) import Import - +import Database.Persist.Sql (rawSql) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import qualified Data.Text as Text getApiR :: Int -> Handler TypedContent getApiR time = do - -- 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 + -- 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 return $ TypedContent typePlain $ toContent t todolistItemToCSV :: Entity TodolistItem -> Text @@ -39,11 +28,9 @@ 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 @@ -51,15 +38,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" \ No newline at end of file diff --git a/src/Handler/Group.hs b/src/Handler/Group.hs index 6c76734..eb15bea 100644 --- a/src/Handler/Group.hs +++ b/src/Handler/Group.hs @@ -1,68 +1,58 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} {-# 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] - 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 + 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 diff --git a/src/Handler/Todolist.hs b/src/Handler/Todolist.hs index c145309..1520130 100644 --- a/src/Handler/Todolist.hs +++ b/src/Handler/Todolist.hs @@ -1,74 +1,61 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} {-# 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" - 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 + text <- lookupPostParams "ids" + let ints = map (read . unpack) text :: [Int64] + let ids = map toSqlKey ints :: [TodolistId] + dbIfAuth groupId (deleteWhere [TodolistId <-. ids]) + 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 \ No newline at end of file diff --git a/src/Handler/TodolistItem.hs b/src/Handler/TodolistItem.hs index 4dc8f7a..9340ff9 100644 --- a/src/Handler/TodolistItem.hs +++ b/src/Handler/TodolistItem.hs @@ -1,117 +1,91 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - {-# HLINT ignore "Replace case with fromMaybe" #-} module Handler.TodolistItem where -import Database.Persist.Sql (rawExecute) import Import +import Database.Persist.Sql (rawExecute) 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]) + 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") - defaultLayout $ do - setTitle "items" - $(widgetFile "todolist-items") postCheckTodolistItemR :: GroupId -> TodolistId -> TodolistItemId -> Handler Html postCheckTodolistItemR groupId todolistId todolistItemId = do - 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 + dbIfAuth groupId (rawExecute "UPDATE todolist_item SET value = NOT value WHERE id = ?" [toPersistValue todolistItemId]) + redirect $ TodolistItemsR groupId todolistId + postAddTodolistItemR :: GroupId -> TodolistId -> Handler Html postAddTodolistItemR groupId todolistId = do - currentTime <- liftIO getCurrentTime - item <- runInputPost $ ireq textField "item" - _ <- - dbIfAuth - groupId - ( do - insert_ $ TodolistItem todolistId False item - update todolistId [TodolistLastModified =. currentTime] - ) - redirect $ TodolistItemsR groupId todolistId + item <- runInputPost $ ireq textField "item" + _ <- dbIfAuth groupId (insert_ $ TodolistItem todolistId False item) + 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 - 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 + mText <- runInputPost $ iopt textField "text" + let xs = case mText of + (Just text) -> getItems text todolistId + Nothing -> [] + dbIfAuth groupId (do deleteWhere [TodolistItemTodolistId ==. todolistId] - 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 + insertMany_ xs) + + 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 + 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 + where read line = do + let (d, n) = splitAt 4 line + let + value = case d of + "[x] " -> True + "[ ] " -> False + _ -> error "Invalid status" + name = case n of + "" -> error "empty name" + something -> filter (/= '\r') something + TodolistItem todolistId value name + +postTrimTodolistItemsR :: GroupId -> TodolistId -> Handler Html +postTrimTodolistItemsR groupId todolistId = 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 \ No newline at end of file diff --git a/stack.yaml b/stack.yaml index 377bf75..3092e82 100644 --- a/stack.yaml +++ b/stack.yaml @@ -20,6 +20,10 @@ 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. # @@ -49,7 +53,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 eef24df..7b81abd 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/lock_files +# https://docs.haskellstack.org/en/stable/topics/lock_files packages: [] snapshots: diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 2ef168a..f18fd65 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -1,10 +1,11 @@
- $maybe msg <- mmsg -
#{msg} - ^{widget} + $maybe msg <- mmsg +
#{msg} + +^{widget}