api ready
This commit is contained in:
parent
67d88bd31b
commit
c4b57d7a29
20 changed files with 440 additions and 568 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue