1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
|
module Persistence.Category
( list
, create
, edit
, delete
) where
import Data.Maybe (isJust, listToMaybe)
import Data.Text (Text)
import Data.Time.Clock (getCurrentTime)
import Database.SQLite.Simple (FromRow (fromRow), Only (Only))
import qualified Database.SQLite.Simple as SQLite
import Prelude hiding (id)
import Common.Model (Category (..), CategoryId)
import Model.Query (Query (Query))
newtype Row = Row Category
instance FromRow Row where
fromRow = Row <$> (Category <$>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field <*>
SQLite.field)
list :: Query [Category]
list =
Query (\conn ->
map (\(Row c) -> c) <$>
SQLite.query_ conn "SELECT * FROM category WHERE deleted_at IS NULL"
)
create :: Text -> Text -> Query CategoryId
create categoryName categoryColor =
Query (\conn -> do
now <- getCurrentTime
SQLite.execute
conn
"INSERT INTO category (name, color, created_at) VALUES (?, ?, ?)"
(categoryName, categoryColor, now)
SQLite.lastInsertRowId conn
)
edit :: CategoryId -> Text -> Text -> Query Bool
edit categoryId categoryName categoryColor =
Query (\conn -> do
mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$>
(SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
if isJust mbCategory
then do
now <- getCurrentTime
SQLite.execute
conn
"UPDATE category SET edited_at = ?, name = ?, color = ? WHERE id = ?"
(now, categoryName, categoryColor, categoryId)
return True
else
return False
)
delete :: CategoryId -> Query Bool
delete categoryId =
Query (\conn -> do
mbCategory <- fmap (\(Row c) -> c) . listToMaybe <$>
(SQLite.query conn "SELECT * FROM category WHERE id = ?" (Only categoryId))
if isJust mbCategory
then do
now <- getCurrentTime
SQLite.execute
conn
"UPDATE category SET deleted_at = ? WHERE id = ?" (now, categoryId)
return True
else
return False
)
|
