From 49426740e8e0c59040f4f3721a658f225572582b Mon Sep 17 00:00:00 2001 From: Joris Date: Tue, 28 Nov 2017 09:11:19 +0100 Subject: Add search for payments --- README.md | 2 +- client/src/Component/Input.hs | 57 ++++++++++++++++++++-------- client/src/Icon.hs | 6 +++ client/src/View/Payment.hs | 26 +++++++++---- client/src/View/Payment/Header.hs | 25 +++++++++--- client/src/View/Payment/Pages.hs | 37 ++++++++++-------- client/src/View/Payment/Table.hs | 9 ++--- client/src/View/SignIn.hs | 2 +- common/src/Common/Message/Key.hs | 2 +- common/src/Common/Message/Translation.hs | 2 +- common/src/Common/Util/Text.hs | 8 +++- server/migrations/1.sql | 65 ++++++++++++++++++++++++++++++++ server/src/Design/Global.hs | 26 +++++++++++++ server/src/Design/Helper.hs | 29 -------------- server/src/Design/View/Header.hs | 8 ++-- server/src/Design/View/Payment/Header.hs | 34 +++++++++-------- server/src/Job/Model.hs | 14 ++++--- 17 files changed, 243 insertions(+), 109 deletions(-) create mode 100644 server/migrations/1.sql diff --git a/README.md b/README.md index e9762ea..aa60885 100644 --- a/README.md +++ b/README.md @@ -26,7 +26,7 @@ Start the environment with: Init the database with migration scripts: ```bash -sqlite3 database < src/migrations/x.sql +sqlite3 database < server/migrations/1.sql ``` Inside the tmux session, add some users with sqlite after the migration is done: diff --git a/client/src/Component/Input.hs b/client/src/Component/Input.hs index 1923463..7eec7d0 100644 --- a/client/src/Component/Input.hs +++ b/client/src/Component/Input.hs @@ -4,13 +4,19 @@ module Component.Input , input ) where -import Data.Text (Text) -import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~), (=:)) -import qualified Reflex.Dom as R +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom (Dynamic, Event, MonadWidget, (&), (.~)) +import qualified Reflex.Dom as R + +import Component.Button (ButtonIn (..), ButtonOut (..)) +import qualified Component.Button as Button +import qualified Icon data InputIn t a b = InputIn - { _inputIn_reset :: Event t a - , _inputIn_placeHolder :: Text + { _inputIn_reset :: Event t a + , _inputIn_label :: Text } data InputOut t = InputOut @@ -19,13 +25,34 @@ data InputOut t = InputOut } input :: forall t m a b. MonadWidget t m => InputIn t a b -> m (InputOut t) -input inputIn = do - let placeHolder = R.constDyn ("placeHolder" =: _inputIn_placeHolder inputIn) - let value = fmap (const "") (_inputIn_reset inputIn) - textInput <- R.textInput $ R.def & R.attributes .~ placeHolder - & R.setValue .~ value - let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput - return $ InputOut - { _inputOut_value = R._textInput_value textInput - , _inputOut_enter = enter - } +input inputIn = + R.divClass "textInput" $ do + rec + let resetValue = R.leftmost + [ fmap (const "") (_inputIn_reset inputIn) + , fmap (const "") (_buttonOut_clic reset) + ] + + attributes = R.ffor value (\v -> + if T.null v then M.empty else M.singleton "class" "filled") + + value = R._textInput_value textInput + + textInput <- R.textInput $ R.def + & R.attributes .~ attributes + & R.setValue .~ resetValue + + R.el "label" $ R.text (_inputIn_label inputIn) + + reset <- Button.button $ ButtonIn + { _buttonIn_class = R.constDyn "" + , _buttonIn_content = Icon.cross + , _buttonIn_waiting = R.never + } + + let enter = fmap (const ()) $ R.ffilter ((==) 13) . R._textInput_keypress $ textInput + + return $ InputOut + { _inputOut_value = value + , _inputOut_enter = enter + } diff --git a/client/src/Icon.hs b/client/src/Icon.hs index e04e2a8..555d928 100644 --- a/client/src/Icon.hs +++ b/client/src/Icon.hs @@ -1,5 +1,6 @@ module Icon ( clone + , cross , delete , edit , loading @@ -21,6 +22,11 @@ clone = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ svgAttr "path" (M.fromList [("d", "M15.143 13.244l.837-2.244 2.698 5.641-5.678 2.502.805-2.23s-8.055-3.538-7.708-10.913c2.715 5.938 9.046 7.244 9.046 7.244zm8.857-7.244v18h-18v-6h-6v-18h18v6h6zm-2 2h-12.112c-.562-.578-1.08-1.243-1.521-2h7.633v-4h-14v14h4v-3.124c.6.961 1.287 1.823 2 2.576v6.548h14v-14z")]) $ R.blank +cross :: forall t m. MonadWidget t m => m () +cross = + svgAttr "svg" (M.fromList [ ("width", "15"), ("height", "15"), ("viewBox", "0 0 1792 1792") ]) $ + svgAttr "path" (M.fromList [("d", "M1490 1322q0 40-28 68l-136 136q-28 28-68 28t-68-28l-294-294-294 294q-28 28-68 28t-68-28l-136-136q-28-28-28-68t28-68l294-294-294-294q-28-28-28-68t28-68l136-136q28-28 68-28t68 28l294 294 294-294q28-28 68-28t68 28l136 136q28 28 28 68t-28 68l-294 294 294 294q28 28 28 68z")]) $ R.blank + delete :: forall t m. MonadWidget t m => m () delete = svgAttr "svg" (M.fromList [ ("width", "24"), ("height", "24"), ("viewBox", "0 0 24 24") ]) $ diff --git a/client/src/View/Payment.hs b/client/src/View/Payment.hs index 15892c4..8aa4d38 100644 --- a/client/src/View/Payment.hs +++ b/client/src/View/Payment.hs @@ -8,9 +8,10 @@ import Prelude hiding (init) import Reflex.Dom (MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Init (..)) +import Common.Model (Frequency (..), Init (..), Payment (..)) +import Common.Util.Text as T -import View.Payment.Header (HeaderIn (..)) +import View.Payment.Header (HeaderIn (..), HeaderOut (..)) import qualified View.Payment.Header as Header import View.Payment.Pages (PagesIn (..), PagesOut (..)) import qualified View.Payment.Pages as Pages @@ -29,15 +30,26 @@ widget :: forall t m. MonadWidget t m => PaymentIn -> m PaymentOut widget paymentIn = do R.divClass "payment" $ do rec - _ <- Header.widget $ HeaderIn + let init = _paymentIn_init paymentIn + + filterPayment s p = search s (_payment_name p) && (_payment_frequency p == Punctual) + + payments = fmap + (\s -> filter (filterPayment s) (_init_payments init)) + (_headerOut_search header) + + header <- Header.widget $ HeaderIn { _headerIn_init = init } + _ <- Table.widget $ TableIn { _tableIn_init = init - , _tableIn_currentPage = _pagesOut_currentPage pagesOut + , _tableIn_currentPage = _pagesOut_currentPage pages + , _tableIn_payments = payments } - pagesOut <- Pages.widget $ PagesIn - { _pagesIn_payments = _init_payments init + + pages <- Pages.widget $ PagesIn + { _pagesIn_payments = payments } + return $ PaymentOut {} - where init = _paymentIn_init paymentIn diff --git a/client/src/View/Payment/Header.hs b/client/src/View/Payment/Header.hs index 3f2adc3..f64f11d 100644 --- a/client/src/View/Payment/Header.hs +++ b/client/src/View/Payment/Header.hs @@ -8,10 +8,11 @@ import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import qualified Data.List as L hiding (groupBy) import Data.Maybe (fromMaybe) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Time as Time import Prelude hiding (init) -import Reflex.Dom (MonadWidget) +import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R import Common.Model (Currency, ExceedingPayer (..), @@ -21,7 +22,8 @@ import qualified Common.Model as CM import qualified Common.Msg as Msg import qualified Common.View.Format as Format -import Component (ButtonIn (..)) +import Component (ButtonIn (..), InputIn (..), + InputOut (..)) import qualified Component as Component import qualified Util.List as L @@ -29,16 +31,19 @@ data HeaderIn t = HeaderIn { _headerIn_init :: Init } -data HeaderOut = HeaderOut - { +data HeaderOut t = HeaderOut + { _headerOut_search :: Dynamic t Text } -widget :: forall t m. MonadWidget t m => HeaderIn t -> m HeaderOut +widget :: forall t m. MonadWidget t m => HeaderIn t -> m (HeaderOut t) widget headerIn = R.divClass "header" $ do payerAndAdd incomes payments users currency + search <- searchLine infos payments users currency - return $ HeaderOut {} + return $ HeaderOut + { _headerOut_search = search + } where init = _headerIn_init headerIn incomes = _init_incomes init payments = filter ((==) Punctual . _payment_frequency) (_init_payments init) @@ -98,3 +103,11 @@ infos payments users currency = . L.groupBy fst . map (\p -> (_payment_user p, _payment_cost p)) $ payments + +searchLine :: forall t m. MonadWidget t m => m (Dynamic t Text) +searchLine = + R.divClass "searchLine" $ + _inputOut_value <$> (Component.input $ InputIn + { _inputIn_reset = R.never + , _inputIn_label = Msg.get Msg.Search_Name + }) diff --git a/client/src/View/Payment/Pages.hs b/client/src/View/Payment/Pages.hs index 81555ab..dfd92c0 100644 --- a/client/src/View/Payment/Pages.hs +++ b/client/src/View/Payment/Pages.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T import Reflex.Dom (Dynamic, Event, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Frequency (..), Payment (..)) +import Common.Model (Payment (..)) import Component (ButtonIn (..), ButtonOut (..)) import qualified Component as Component @@ -16,52 +16,57 @@ import qualified Component as Component import qualified Icon import qualified View.Payment.Constants as Constants -data PagesIn = PagesIn - { _pagesIn_payments :: [Payment] +data PagesIn t = PagesIn + { _pagesIn_payments :: Dynamic t [Payment] } data PagesOut t = PagesOut { _pagesOut_currentPage :: Dynamic t Int } -widget :: forall t m. MonadWidget t m => PagesIn -> m (PagesOut t) +widget :: forall t m. MonadWidget t m => PagesIn t -> m (PagesOut t) widget pagesIn = do R.divClass "pages" $ do rec currentPage <- R.holdDyn 1 . R.leftmost $ [ firstPageClic, previousPageClic, pageClic, nextPageClic, lastPageClic ] - firstPageClic <- pageButton (R.constDyn 0) (R.constDyn 1) Icon.doubleLeftBar + firstPageClic <- pageButton noCurrentPage (R.constDyn 1) Icon.doubleLeftBar - previousPageClic <- pageButton (R.constDyn 0) (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft + previousPageClic <- pageButton noCurrentPage (fmap (\x -> max (x - 1) 1) currentPage) Icon.doubleLeft - pageClic <- pageEvent <$> (R.simpleList (fmap (range maxPage) currentPage) $ \p -> - pageButton currentPage p (R.dynText $ fmap (T.pack . show) p)) + pageClic <- pageEvent <$> (R.simpleList (range <$> currentPage <*> maxPage) $ \p -> + pageButton (Just <$> currentPage) p (R.dynText $ fmap (T.pack . show) p)) - nextPageClic <- pageButton (R.constDyn 0) (fmap (\x -> min (x + 1) maxPage) currentPage) Icon.doubleRight + nextPageClic <- pageButton noCurrentPage ((\c m -> min (c + 1) m) <$> currentPage <*> maxPage) Icon.doubleRight - lastPageClic <- pageButton (R.constDyn 0) (R.constDyn maxPage) Icon.doubleRightBar + lastPageClic <- pageButton noCurrentPage maxPage Icon.doubleRightBar return $ PagesOut { _pagesOut_currentPage = currentPage } - where paymentCount = length . filter ((==) Punctual . _payment_frequency) . _pagesIn_payments $ pagesIn - maxPage = ceiling $ toRational paymentCount / toRational Constants.paymentsPerPage + where maxPage = + R.ffor (_pagesIn_payments pagesIn) (\payments -> + ceiling $ toRational (length payments) / toRational Constants.paymentsPerPage + ) + pageEvent = R.switchPromptlyDyn . fmap R.leftmost + noCurrentPage = R.constDyn Nothing + range :: Int -> Int -> [Int] -range maxPage currentPage = [start..end] +range currentPage maxPage = [start..end] where sidePages = 2 - start = max 1 (currentPage - sidePages) + start = max 1 (min (currentPage - sidePages) (maxPage - sidePages * 2)) end = min maxPage (start + sidePages * 2) -pageButton :: forall t m. MonadWidget t m => Dynamic t Int -> Dynamic t Int -> m () -> m (Event t Int) +pageButton :: forall t m. MonadWidget t m => Dynamic t (Maybe Int) -> Dynamic t Int -> m () -> m (Event t Int) pageButton currentPage page content = do clic <- _buttonOut_clic <$> (Component.button $ ButtonIn { _buttonIn_class = do cp <- currentPage p <- page - if cp == p then "page current" else "page" + if cp == Just p then "page current" else "page" , _buttonIn_content = content , _buttonIn_waiting = R.never }) diff --git a/client/src/View/Payment/Table.hs b/client/src/View/Payment/Table.hs index d8093a5..0c3b769 100644 --- a/client/src/View/Payment/Table.hs +++ b/client/src/View/Payment/Table.hs @@ -12,8 +12,7 @@ import Prelude hiding (init) import Reflex.Dom (Dynamic, MonadWidget) import qualified Reflex.Dom as R -import Common.Model (Category (..), Frequency (..), - Init (..), Payment (..), +import Common.Model (Category (..), Init (..), Payment (..), PaymentCategory (..), User (..)) import qualified Common.Model as CM import qualified Common.Msg as Msg @@ -26,6 +25,7 @@ import qualified View.Payment.Constants as Constants data TableIn t = TableIn { _tableIn_init :: Init , _tableIn_currentPage :: Dynamic t Int + , _tableIn_payments :: Dynamic t [Payment] } data TableOut = TableOut @@ -47,8 +47,8 @@ widget tableIn = do R.divClass "cell" $ R.blank let init = _tableIn_init tableIn currentPage = _tableIn_currentPage tableIn - payments = _init_payments init - paymentRange = fmap (getPaymentRange payments) currentPage + payments = _tableIn_payments tableIn + paymentRange = getPaymentRange <$> payments <*> currentPage R.simpleList paymentRange (paymentRow init) return $ TableOut {} @@ -58,7 +58,6 @@ getPaymentRange payments currentPage = . drop ((currentPage - 1) * Constants.paymentsPerPage) . reverse . L.sortOn _payment_date - . filter ((==) Punctual . _payment_frequency) $ payments paymentRow :: forall t m. MonadWidget t m => Init -> Dynamic t Payment -> m () diff --git a/client/src/View/SignIn.hs b/client/src/View/SignIn.hs index 69596d8..be6b152 100644 --- a/client/src/View/SignIn.hs +++ b/client/src/View/SignIn.hs @@ -23,7 +23,7 @@ view result = rec input <- Component.input $ InputIn { _inputIn_reset = R.ffilter Either.isRight signInResult - , _inputIn_placeHolder = Msg.get Msg.SignIn_EmailPlaceholder + , _inputIn_label = Msg.get Msg.SignIn_EmailLabel } let userWantsEmailValidation = _inputOut_enter input <> _buttonOut_clic button diff --git a/common/src/Common/Message/Key.hs b/common/src/Common/Message/Key.hs index ad8a7f1..a6828d5 100644 --- a/common/src/Common/Message/Key.hs +++ b/common/src/Common/Message/Key.hs @@ -118,7 +118,7 @@ data Key = | SignIn_Button | SignIn_DisconnectSuccess | SignIn_EmailInvalid - | SignIn_EmailPlaceholder + | SignIn_EmailLabel | SignIn_EmailSendFail | SignIn_EmailSent | SignIn_LinkExpired diff --git a/common/src/Common/Message/Translation.hs b/common/src/Common/Message/Translation.hs index 0a6084d..13ced15 100644 --- a/common/src/Common/Message/Translation.hs +++ b/common/src/Common/Message/Translation.hs @@ -517,7 +517,7 @@ m l SignIn_EmailInvalid = English -> "Your email is not valid." French -> "Votre courriel n’est pas valide." -m l SignIn_EmailPlaceholder = +m l SignIn_EmailLabel = case l of English -> "Email" French -> "Courriel" diff --git a/common/src/Common/Util/Text.hs b/common/src/Common/Util/Text.hs index 7e5c8c2..b49fc55 100644 --- a/common/src/Common/Util/Text.hs +++ b/common/src/Common/Util/Text.hs @@ -1,10 +1,16 @@ module Common.Util.Text - ( unaccent + ( search + , unaccent ) where import Data.Text (Text) import qualified Data.Text as T +search :: Text -> Text -> Bool +search s t = + (format s) `T.isInfixOf` (format t) + where format = T.toLower . unaccent + unaccent :: Text -> Text unaccent = T.map unaccentChar diff --git a/server/migrations/1.sql b/server/migrations/1.sql new file mode 100644 index 0000000..d7c300e --- /dev/null +++ b/server/migrations/1.sql @@ -0,0 +1,65 @@ +CREATE TABLE IF NOT EXISTS "user" ( + "id" INTEGER PRIMARY KEY, + "creation" TIMESTAMP NOT NULL, + "email" VARCHAR NOT NULL, + "name" VARCHAR NOT NULL, + CONSTRAINT "uniq_user_email" UNIQUE ("email"), + CONSTRAINT "uniq_user_name" UNIQUE ("name") +); + +CREATE TABLE IF NOT EXISTS "job" ( + "id" INTEGER PRIMARY KEY, + "kind" VARCHAR NOT NULL, + "last_execution" TIMESTAMP NULL, + "last_check" TIMESTAMP NULL, + CONSTRAINT "uniq_job_kind" UNIQUE ("kind") +); + +CREATE TABLE IF NOT EXISTS "sign_in"( + "id" INTEGER PRIMARY KEY, + "token" VARCHAR NOT NULL, + "creation" TIMESTAMP NOT NULL, + "email" VARCHAR NOT NULL, + "is_used" BOOLEAN NOT NULL, + CONSTRAINT "uniq_sign_in_token" UNIQUE ("token") +); + +CREATE TABLE IF NOT EXISTS "payment"( + "id" INTEGER PRIMARY KEY, + "user_id" INTEGER NOT NULL REFERENCES "user", + "name" VARCHAR NOT NULL, + "cost" INTEGER NOT NULL, + "date" DATE NOT NULL, + "frequency" VARCHAR NOT NULL, + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + "deleted_at" TIMESTAMP NULL +); + +CREATE TABLE IF NOT EXISTS "income"( + "id" INTEGER PRIMARY KEY, + "user_id" INTEGER NOT NULL REFERENCES "user", + "date" DATE NOT NULL, + "amount" INTEGERNOT NULL, + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + "deleted_at" TIMESTAMP NULL +); + +CREATE TABLE IF NOT EXISTS "category"( + "id" INTEGER PRIMARY KEY, + "name" VARCHAR NOT NULL, + "color" VARCHAR NOT NULL, + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + "deleted_at" TIMESTAMP NULL +); + +CREATE TABLE IF NOT EXISTS "payment_category"( + "id" INTEGER PRIMARY KEY, + "name" VARCHAR NOT NULL, + "category" INTEGER NOT NULL REFERENCES "category", + "created_at" TIMESTAMP NOT NULL, + "edited_at" TIMESTAMP NULL, + CONSTRAINT "uniq_payment_category_name" UNIQUE ("name") +); diff --git a/server/src/Design/Global.hs b/server/src/Design/Global.hs index 34d772e..5e5035c 100644 --- a/server/src/Design/Global.hs +++ b/server/src/Design/Global.hs @@ -71,3 +71,29 @@ global = do ".undo" & Helper.button Color.silver Color.white (px Constants.inputHeight) Constants.focusLighten svg ? height (pct 100) + + button ? do + ".content" ? display flex + svg # ".loader" ? display none + + ".waiting" & do + ".content" ? do + display none + svg # ".loader" ? do + display block + rotateKeyframes + rotateAnimation + +rotateAnimation :: Css +rotateAnimation = do + animationName "rotate" + animationDuration (sec 1) + animationTimingFunction easeOut + animationIterationCount infinite + +rotateKeyframes :: Css +rotateKeyframes = keyframes + "rotate" + [ (0, "transform" -: "rotate(0deg)") + , (100, "transform" -: "rotate(360deg)") + ] diff --git a/server/src/Design/Helper.hs b/server/src/Design/Helper.hs index 89f5958..6980c71 100644 --- a/server/src/Design/Helper.hs +++ b/server/src/Design/Helper.hs @@ -1,7 +1,6 @@ module Design.Helper ( clearFix , button - , waitable , input , centeredWithMargin , verticalCentering @@ -37,20 +36,6 @@ button backgroundCol textCol h focusOp = do textAlign (alignSide sideCenter) hover & backgroundColor (focusOp backgroundCol) focus & backgroundColor (focusOp backgroundCol) - waitable - -waitable :: Css -waitable = do - ".content" ? display flex - svg # ".loader" ? display none - - ".waiting" & do - ".content" ? do - display none - svg # ".loader" ? do - display block - rotateKeyframes - rotateAnimation input :: Double -> Css input h = do @@ -72,17 +57,3 @@ verticalCentering = do position absolute top (pct 50) "transform" -: "translateY(-50%)" - -rotateAnimation :: Css -rotateAnimation = do - animationName "rotate" - animationDuration (sec 1) - animationTimingFunction easeOut - animationIterationCount infinite - -rotateKeyframes :: Css -rotateKeyframes = keyframes - "rotate" - [ (0, "transform" -: "rotate(0deg)") - , (100, "transform" -: "rotate(360deg)") - ] diff --git a/server/src/Design/View/Header.hs b/server/src/Design/View/Header.hs index 904a2f5..97f1802 100644 --- a/server/src/Design/View/Header.hs +++ b/server/src/Design/View/Header.hs @@ -2,13 +2,12 @@ module Design.View.Header ( design ) where -import Data.Monoid ((<>)) +import Data.Monoid ((<>)) import Clay -import Design.Color as Color -import qualified Design.Helper as Helper -import qualified Design.Media as Media +import Design.Color as Color +import qualified Design.Media as Media design :: Css design = do @@ -56,7 +55,6 @@ design = do Media.tabletDesktop $ headerPadding ".signOut" ? do - Helper.waitable display flex svg ? do Media.tabletDesktop $ width (px 30) diff --git a/server/src/Design/View/Payment/Header.hs b/server/src/Design/View/Payment/Header.hs index 36bc8d9..80c5436 100644 --- a/server/src/Design/View/Payment/Header.hs +++ b/server/src/Design/View/Payment/Header.hs @@ -50,22 +50,24 @@ design = do ".searchLine" ? do marginBottom (em 1) - form ? do - Media.mobile $ textAlign (alignSide sideCenter) - - ".textInput" ? do - display inlineBlock - marginBottom (px 0) - - Media.tabletDesktop $ marginRight (px 30) - Media.mobile $ do - marginBottom (em 1) - width (pct 100) - - ".radioGroup" ? do - display inlineBlock - marginBottom (px 0) - ".title" ? display none + Media.mobile $ textAlign (alignSide sideCenter) + + ".textInput" ? do + display inlineBlock + marginBottom (px 0) + button ? do + svg ? "path" ? ("fill" -: Color.toString Color.silver) + hover & svg ? "path" ? ("fill" -: Color.toString (Color.silver -. 25)) + + Media.tabletDesktop $ marginRight (px 30) + Media.mobile $ do + marginBottom (em 1) + width (pct 100) + + ".radioGroup" ? do + display inlineBlock + marginBottom (px 0) + ".title" ? display none ".infos" ? do Media.tabletDesktop $ lineHeight (px Constants.inputHeight) diff --git a/server/src/Job/Model.hs b/server/src/Job/Model.hs index a5fa62b..1dd6c63 100644 --- a/server/src/Job/Model.hs +++ b/server/src/Job/Model.hs @@ -5,7 +5,6 @@ module Job.Model , actualizeLastCheck ) where -import Data.Maybe (isJust) import Data.Time.Clock (UTCTime, getCurrentTime) import Database.SQLite.Simple (Only (Only)) import qualified Database.SQLite.Simple as SQLite @@ -24,15 +23,20 @@ data Job = Job getLastExecution :: Kind -> Query (Maybe UTCTime) getLastExecution jobKind = Query (\conn -> do - [Only time] <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe UTCTime)] - return time + result <- SQLite.query conn "SELECT last_execution FROM job WHERE kind = ?" (Only jobKind) :: IO [Only UTCTime] + return $ case result of + [Only time] -> Just time + _ -> Nothing ) actualizeLastExecution :: Kind -> UTCTime -> Query () actualizeLastExecution jobKind time = Query (\conn -> do - [Only result] <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only (Maybe Int)] - if isJust result + result <- SQLite.query conn "SELECT 1 FROM job WHERE kind = ?" (Only jobKind) :: IO [Only Int] + let hasJob = case result of + [Only _] -> True + _ -> False + if hasJob then SQLite.execute conn "UPDATE job SET last_execution = ? WHERE kind = ?" (time, jobKind) else SQLite.execute conn "INSERT INTO job (kind, last_execution, last_check) VALUES (?, ?, ?)" (jobKind, time, time) ) -- cgit v1.2.3